From 40354e492d88f0edfee45a31203063b88e9efa3d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matth=C3=A4us=20Kuhn?= Date: Thu, 11 Dec 2025 17:07:30 +0100 Subject: [PATCH] inital import --- Dockerfile | 74 + README.md | 38 + html/imapsync_form.css | 41 + html/imapsync_form.js | 851 ++ html/imapsync_form_extra.html | 375 + imapsync | 21984 ++++++++++++++++++++++++++++++++ 6 files changed, 23363 insertions(+) create mode 100644 Dockerfile create mode 100644 README.md create mode 100644 html/imapsync_form.css create mode 100644 html/imapsync_form.js create mode 100644 html/imapsync_form_extra.html create mode 100644 imapsync diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 0000000..3c7dfe7 --- /dev/null +++ b/Dockerfile @@ -0,0 +1,74 @@ +## Dockerfile ofr building a docker imapsync image with WebUI + +# docker build -t mrickl/imapsyncwithwebui + +#Documentation cooming Soon + +FROM debian:stable + +LABEL maintainer="deadmanIsARabbit" \ + description="Imapsync with WebUI" + + +RUN sed -i 's/Components: main/Components: main contrib non-free-firmware non-free/g' /etc/apt/sources.list.d/debian.sources + +RUN set -xe && \ + apt-get update && \ + apt-get install -y \ + libauthen-ntlm-perl \ + libcgi-pm-perl \ + libcrypt-openssl-rsa-perl \ + libdata-uniqid-perl \ + libencode-imaputf7-perl \ + libfile-copy-recursive-perl \ + libfile-tail-perl \ + libhttp-daemon-perl \ + libhttp-daemon-ssl-perl \ + libhttp-message-perl \ + libio-socket-inet6-perl \ + libio-socket-ssl-perl \ + libio-tee-perl \ + libhtml-parser-perl \ + libjson-webtoken-perl \ + libmail-imapclient-perl \ + libmodule-scandeps-perl \ + libnet-server-perl \ + libnet-dns-perl \ + libparse-recdescent-perl \ + libproc-processtable-perl \ + libreadonly-perl \ + libregexp-common-perl \ + libsys-meminfo-perl \ + libterm-readkey-perl \ + libtest-mockobject-perl \ + libunicode-string-perl \ + liburi-perl \ + libwww-perl \ + make \ + time \ + cpanminus \ + wget \ + curl \ + procps \ + lighttpd + +ENV LIGHTHTTPD_RUN_USER www-data +ENV LIGHTHTTPD_RUN_GROUP www-data + +RUN echo "server.stream-response-body = 1" >> /etc/lighttpd/lighttpd.conf +RUN lighty-enable-mod cgi +RUN service lighttpd force-reload + +RUN mkdir -p /usr/lib/cgi-bin +RUN rm -f /var/www/html/index.html + +#always pull the latest version of imapsync +RUN curl https://raw.githubusercontent.com/imapsync/imapsync/master/imapsync > /usr/lib/cgi-bin/imapsync +RUN chmod +x /usr/lib/cgi-bin/imapsync + +#copy the webui files +COPY html /var/www/html +RUN ln -s /var/www/html/imapsync_form_extra.html /var/www/html/index.html + +EXPOSE 80 +CMD ["lighttpd", "-D", "-f", "etc/lighttpd/lighttpd.conf"] \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..a29be79 --- /dev/null +++ b/README.md @@ -0,0 +1,38 @@ +# Imapsync with WebUI +(forked from [mrickl/ImapsyncWebUI](https://github.com/mrickl/ImapsyncWebUI)) + +## German +Dies ist das Repostiory für das Docker Container "Imapsyncwithwebui" + +Imapsync with WebUI ist eine Kombination aus dem Imapsync von https://imapsync.lamiral.info/ und seiner WebUI. + +Da es bisher nur das Imapsync als Docker gab, aber bisher nicht in Kombination mit der WebUI habe ich dieses Docker Container gebaut. + +Der Webserver Port innerhalb des Containers ist Port 80. + +Installtion des Containers: + +## English +This is the repostiory for the Docker container "Imapsyncwithwebui". + +Imapsync with WebUI is a combination of the Imapsync from https://imapsync.lamiral.info/ and his WebUI. + +Since so far there was only the Imapsync as Docker, but so far not in combination with the WebUI . + +The web server port inside the container is port 80. + +Installtion of the container: + +## Installation +### Build +> docker build --tag 'deadmanIsARabbit/imapsyncwithwebui' . +### Run +> docker run -d --name imapsync -p 80:80 deadmanIsARabbit/imapsyncwithwebui + +## Information + +Der "Abort" Button hat im Docker Container keine Funktion, aufgrund der im Docker befindlichen /.dockerenv Datei. Hierfür gibt es allerdings einen Workaround, wodurch das Abbrechen der Sync Jobs möglich ist. Ich bin bereits an einer Lösung dran damit der Workaround nicht benötigt wird + +The "Abort" button has no function in the Docker container, because of the /.dockerenv file located in Docker. However, there is a workaround for this, which makes it possible to abort the sync jobs. I am already working on a solution so that the workaround is not needed. + +> docker exec imapsync rm ./dockerenv \ No newline at end of file diff --git a/html/imapsync_form.css b/html/imapsync_form.css new file mode 100644 index 0000000..86c0822 --- /dev/null +++ b/html/imapsync_form.css @@ -0,0 +1,41 @@ +/* $Id: imapsync_form.css,v 1.8 2019/11/25 13:49:18 gilles Exp gilles $ */ + +#account1 { + background-color: DodgerBlue ; + /* background-color: Fuchsia ; */ + /* background-color: RoyalBlue ; */ +} + +#account2 { + background-color: DarkTurquoise ; +} + +#parameters { + /* background-color: GreenYellow ; */ + /* background-color: White ; */ +} + +#progress-txt { + text-align: center ; + font-size: 1.4em ; + margin: 0 0 0px ; + height: 50px ; +} + +.progress { + /* text-align: center ; */ + /* font-size: 1.4em ; */ + margin: 0 0 0px ; +} + +.progress-bar { + text-align: center ; + font-size: 1.4em ; + margin: 0 0 0px ; +} + + +.padd0 { + padding-left: 0px ; + padding-right: 0px ; +} \ No newline at end of file diff --git a/html/imapsync_form.js b/html/imapsync_form.js new file mode 100644 index 0000000..4d741f5 --- /dev/null +++ b/html/imapsync_form.js @@ -0,0 +1,851 @@ + +// $Id: proximapsync_form.js,v 1.15 2025/10/18 14:16:20 gilles Exp gilles $ + +/*jslint browser: true*/ /*global $*/ + + +/* +1) How the hell is structured this code? +2) What is its behavior? + + +*/ + + +var readyStateStr = { + "0": "Request not initialized", + "1": "Server connection established", + "2": "Response headers received", + "3": "Processing request", + "4": "Finished and response is ready" +}; + +var refresh_interval_ms = 2000; +var refresh_interval_s = refresh_interval_ms / 1000; +var test = { + counter_all: 0, + counter_ok: 0, + counter_nok: 0, + failed_tests: "" +}; + +var is = function is(expected, given, comment) { + test.counter_all += 1; + var message = test.counter_all + " - [" + + expected + + "] === [" + + given + + "] " + + comment + + "\n"; + if (expected === given) { + test.counter_ok += 1; + message = "ok " + message; + } + else { + test.counter_nok += 1; + test.failed_tests += "nb " + message + "\n"; + message = "not ok " + message; + } + $("#tests").append(message); +}; + +var note = function note(message) { + $("#tests").append(message); +}; + + +var tests_last_x_lines = function tests_last_x_lines() { + is("", last_x_lines(), "last_x_lines: no args => empty string"); + is("", last_x_lines(""), "last_x_lines: empty string => empty string"); + is("abc", last_x_lines("abc"), "last_x_lines: abc => abc"); + is("abc\ndef", last_x_lines("abc\ndef"), "last_x_lines: abc\ndef => abc\ndef"); + is("def", last_x_lines("abc\ndef", -1), "last_x_lines: abc\ndef -1 => def\n"); + is("", last_x_lines("abc\ndef", 0), "last_x_lines: abc\ndef 0 => empty string"); + is("abc\ndef", last_x_lines("abc\ndef", -10), "last_x_lines: last 10 of 2 lines => 2 lines"); + is("4\n5\n", last_x_lines("1\n2\n3\n4\n5\n", -3), "last_x_lines: last 3 lines of 5 lines"); + is("3\n4\n5", last_x_lines("1\n2\n3\n4\n5", -3), "last_x_lines: last 3 lines of 5 lines"); +}; + +var last_x_lines = function last_x_lines(string, num) { + if (undefined === string || 0 === num) { + return ""; + } + return string.split(/\r?\n/).slice(num).join("\n"); +}; + +var last_eta = function last_eta(string) { + // return the last occurrence of the substring "ETA: ...\n" + // or "ETA: unknown" or "" + var eta; + var last_found; + + if (undefined === string) { + return ""; + } + + var eta_re = /ETA:.*\n/g; + + eta = string.match(eta_re); + if (eta) { + last_found = eta[eta.length - 1]; + return last_found; + } + else { + return "ETA: unknown"; + } +} + + + +var tests_last_eta = function tests_last_eta() { + is("", last_eta(), "last_eta: no args => empty string"); + + is( + "ETA: unknown", + last_eta(""), + "last_eta: empty => empty string"); + + is("ETA: unknown", + last_eta("ETA"), + "last_eta: ETA => empty string"); + + is("ETA: unknown", last_eta("ETA: but no CR"), + "last_eta: ETA: but no CR => empty string"); + + is( + "ETA: with CR\n", + last_eta("Blabla ETA: with CR\n"), + "last_eta: ETA: with CR => ETA: with CR" + ); + + is( + "ETA: 2 with CR\n", + last_eta("Blabla ETA: 1 with CR\nBlabla ETA: 2 with CR\n"), + "last_eta: several ETA: with CR => ETA: 2 with CR" + ); +} + +var tests_decompose_eta_line = function tests_decompose_eta_line() { + var eta_obj; + var eta_str = "ETA: Wed Jul 3 14:55:27 2019 1234 s 123/4567 msgs left\n"; + + eta_obj = decompose_eta_line(""); + is( + "", + eta_obj.str, + "decompose_eta_line: no match => undefined" + ); + + + eta_obj = decompose_eta_line(eta_str); + is( + eta_str, + eta_str, + "decompose_eta_line: str is str" + ); + + is( + eta_str, + eta_obj.str, + "decompose_eta_line: str back" + ); + + is( + "Wed Jul 3 14:55:27 2019", + eta_obj.date, + "decompose_eta_line: date" + ); + + is( + "1234", + eta_obj.seconds_left, + "decompose_eta_line: seconds_left" + ); + + is( + "123", + eta_obj.msgs_left, + "decompose_eta_line: msgs_left" + ); + + is( + "4567", + eta_obj.msgs_total, + "decompose_eta_line: msgs_total" + ); + + is( + "4444", + eta_obj.msgs_done(), + "decompose_eta_line: msgs_done" + ); + + is( + "97.31", + eta_obj.percent_done(), + "decompose_eta_line: percent_done" + ); + + is( + "2.69", + eta_obj.percent_left(), + "decompose_eta_line: percent_left" + ); +}; + +var decompose_eta_line = function decompose_eta_line(eta_str) { + var eta_obj; + var eta_array; + + var regex_eta = /^ETA:\s+(.*?)\s+([0-9]+)\s+s\s+([0-9]+)\/([0-9]+)\s+msgs\s+left\n?$/; + eta_array = regex_eta.exec(eta_str); + + if (null !== eta_array) { + eta_obj = { + str: eta_str, + date: eta_array[1], + seconds_left: eta_array[2], + msgs_left: eta_array[3], + msgs_total: eta_array[4], + msgs_done: function () { + var diff = eta_obj.msgs_total - eta_obj.msgs_left; + return (diff.toString()); + }, + percent_done: function () { + var percent; + if (0 === eta_obj.msgs_total) { + return "0"; + } + else { + percent = (eta_obj.msgs_total - eta_obj.msgs_left) / eta_obj.msgs_total * 100; + return (percent.toFixed(2)); + } + }, + percent_left: function () { + var percent; + if (0 === eta_obj.msgs_total) { + return "0"; + } + else { + percent = (eta_obj.msgs_left / eta_obj.msgs_total * 100); + return (percent.toFixed(2)); + } + } + }; + } + else { + eta_obj = { + str: "", + date: "?", + seconds_left: "?", + msgs_left: "?", + msgs_total: "?", + msgs_done: "?", + percent_done: function () { return ""; }, + percent_left: function () { return ""; } + }; + } + + return eta_obj; +}; + +var extract_eta = function extract_eta(xhr) { + var eta_obj; + var slice_length; + var slice_log; + var eta_str; + + if (!xhr || typeof xhr.responseText !== "string") { + return { + str: "", + date: "?", + seconds_left: "?", + msgs_left: "?", + msgs_total: "?", + msgs_done: "?", + percent_done: function () { return ""; }, + percent_left: function () { return ""; } + }; + } + + // wie bisher: nur den letzten Teil des Logs betrachten + if (xhr.readyState === 4) { + slice_length = -24000; + } else { + slice_length = -2400; + } + + slice_log = xhr.responseText.slice(slice_length); + + // 1. Versuch: originale ETA-Zeile (ETA: ... msgs left) + var eta_re = /ETA:.*\n/g; + var all_etas = slice_log.match(eta_re); + if (all_etas && all_etas.length) { + eta_str = all_etas[all_etas.length - 1]; + eta_obj = decompose_eta_line(eta_str); + if (eta_obj && eta_obj.str && eta_obj.str.length) { + return eta_obj; + } + } + + // 2. Fallback: nur "NNN/TTT msgs left" ohne strengen ETA-Header + var msgs_re = /(\d+)\s*\/\s*(\d+)\s+msgs\s+left/g; + var m; + var last = null; + while ((m = msgs_re.exec(slice_log)) !== null) { + last = m; + } + + if (last) { + var left = parseInt(last[1], 10); + var total = parseInt(last[2], 10); + if (!isFinite(left) || !isFinite(total) || total === 0) { + // zur Sicherheit: zurück auf "unknown" + } else { + eta_obj = { + // künstliche ETA-String-Repräsentation + str: "ETA: ? ? s " + left + "/" + total + " msgs left\n", + date: "?", + seconds_left: "?", + msgs_left: left, + msgs_total: total, + msgs_done: function () { + return (eta_obj.msgs_total - eta_obj.msgs_left); + }, + percent_done: function () { + var percent = (eta_obj.msgs_total - eta_obj.msgs_left) / + eta_obj.msgs_total * 100; + return percent.toFixed(2); + }, + percent_left: function () { + var percent = eta_obj.msgs_left / eta_obj.msgs_total * 100; + return percent.toFixed(2); + } + }; + return eta_obj; + } + } + + // 3. Kein Fortschritts-Muster gefunden → "unknown" + return { + str: "", + date: "?", + seconds_left: "?", + msgs_left: "?", + msgs_total: "?", + msgs_done: "?", + percent_done: function () { return ""; }, + percent_left: function () { return ""; } + }; +}; + +var progress_bar_update = function progress_bar_update(eta_obj) { + if (eta_obj.str.length) { + $("#progress-bar-done").css("width", eta_obj.percent_done() + "%").attr("aria-valuenow", eta_obj.percent_done()); + $("#progress-bar-left").css("width", eta_obj.percent_left() + "%").attr("aria-valuenow", eta_obj.percent_left()); + $("#progress-bar-done").text(eta_obj.percent_done() + "% " + "done"); + $("#progress-bar-left").text(eta_obj.percent_left() + "% " + "left"); + } + else { + $("#progress-bar-done").text("unknown % " + "done"); + $("#progress-bar-left").text("unknown % " + "left"); + } + return; +}; + + +var refreshLog = function refreshLog(xhr) { + var eta_obj; + var eta_str; + + if (!xhr) { + return; + } + + // ETA aus dem aktuellen Response-Text holen + eta_obj = extract_eta(xhr); + progress_bar_update(eta_obj); + + if (xhr.readyState === 4) { + // Ende des Syncs + $("#progress-txt").text( + "Ended. It remains " + + eta_obj.msgs_left + " messages to be synced" + ); + } else { + eta_str = eta_obj.str + " (refresh done every " + refresh_interval_s + " s)"; + eta_str = eta_str.replace(/(\r\n|\n|\r)/gm, ""); // Zeilenumbrüche trimmen + $("#progress-txt").text(eta_str); + } +}; + + +var handleRun = function handleRun(xhr) { + if (!xhr) { + return; + } + + var time = new Date(); + + // XHR-Status in #console schreiben + $("#console").append( + "Status: " + xhr.status + " " + xhr.statusText + "\n" + + "State: " + readyStateStr[xhr.readyState] + "\n" + + "Time: " + time + "\n\n" + ); + + // Progress/ETA aktualisieren + refreshLog(xhr); + + if (xhr.readyState === 4) { + // Request fertig → Buttons wieder sinnvoll setzen + $("#bt-sync").prop("disabled", false); + $("#bt-abort").prop("disabled", true); + } +}; + +var imapsync = function imapsync() { + var querystring = $("#form").serialize(); + //console.log(querystring); + $("#abort").text("\n\n\n"); // clean abort console + + var consoleEl = document.getElementById("console"); + var outputEl = document.getElementById("output"); + + // Startzustand + outputEl.textContent = "Here comes the log!\n\n"; + + // Zusätzliche Flags aus dem Original + if ("imap.gmail.com" === $("#host1").val()) { + querystring = querystring + "&gmail1=on"; + } + if ("imap.gmail.com" === $("#host2").val()) { + querystring = querystring + "&gmail2=on"; + } + if ("outlook.office365.com" === $("#host1").val()) { + querystring = querystring + "&office1=on"; + } + if ("outlook.office365.com" === $("#host2").val()) { + querystring = querystring + "&office2=on"; + } + if ("export.imap.mail.yahoo.com" === $("#host1").val()) { + querystring = querystring + "&yahoo1=on"; + } + + // URL aus dem Formular (HTML: action="/cgi-bin/imapsync") + var url = $("#form").attr("action") || "/cgi-bin/imapsync"; + + var xhr = new XMLHttpRequest(); + var lastLength = 0; // wie weit responseText schon verarbeitet wurde + + // Hilfsfunktion: nur neue Chunks anhängen + var appendChunk = function () { + var full = xhr.responseText || ""; + var chunk = full.substring(lastLength); + if (chunk.length > 0) { + lastLength = full.length; + outputEl.textContent += chunk; + // immer ans Ende scrollen + outputEl.scrollTop = outputEl.scrollHeight; + } + }; + + xhr.open("POST", url, true); + xhr.setRequestHeader( + "Content-type", + "application/x-www-form-urlencoded" + ); + + // readyState-Änderung → Status + Progress + xhr.onreadystatechange = function () { + handleRun(xhr); + }; + + // bei jeder neuen Datenportion + xhr.onprogress = function () { + appendChunk(); // neue Log-Zeilen nach #output + handleRun(xhr); // Fortschrittsbalken + #console updaten + console.log("onprogress"); + }; + + // am Ende sicherstellen, dass auch der letzte Rest dran ist + xhr.onload = function () { + appendChunk(); + handleRun(xhr); + console.log("onload"); + }; + + xhr.onerror = function () { + var msg = "\n--- XHR Fehler ---\n" + + "readyState=" + xhr.readyState + "\n" + + "status=" + xhr.status + " " + xhr.statusText + "\n"; + + outputEl.textContent += msg; + + // Buttons wieder freigeben + $("#bt-sync").prop("disabled", false); + $("#bt-abort").prop("disabled", true); + }; + + xhr.send(querystring); +}; + +var handleAbort = function handleAbort(xhr) { + const time = new Date(); + $("#abort").text( + "Status: " + xhr.status + " " + xhr.statusText + "\n" + + "State: " + readyStateStr[xhr.readyState] + "\n" + + "Time: " + time + "\n" + ); + + if (xhr.readyState === 4) { + $("#abort").append(xhr.responseText); + $("#bt-sync").prop("disabled", false); + $("#bt-abort").prop("disabled", false); // back for next abort + } +} + +var abort = function abort() { + var querystring = $("#form").serialize() + "&abort=on"; + var xhr; + xhr = new XMLHttpRequest(); + xhr.onreadystatechange = function () { + handleAbort(xhr); + }; + xhr.open("POST", "/cgi-bin/imapsync", true); + xhr.setRequestHeader("Content-type", "application/x-www-form-urlencoded"); + xhr.send(querystring); +} + +var store = function store(id) { + var stored; + //$( "#tests" ).append( "Eco: " + id + " type is " + $( id ).attr( "type" ) + "\n" ) ; + if ("text" === $(id).attr("type") || "password" === $(id).attr("type")) { + localStorage.setItem(id, $(id).val()); + stored = $(id).val(); + } + else if ("checkbox" === $(id).attr("type")) { + //$( "#tests" ).append( "Eco: " + id + " checked is " + $( id )[0].checked + "\n" ) ; + localStorage.setItem(id, $(id)[0].checked); + stored = $(id)[0].checked; + } + return stored; +} + +var retrieve = function retrieve(id) { + var retrieved; + //$( "#tests" ).append( "Eco: " + id + " type is " + $( id ).attr( "type" ) + " length is " + $( id ).length + "\n" ) ; + if ("text" === $(id).attr("type") || "password" === $(id).attr("type")) { + $(id).val(localStorage.getItem(id)); + retrieved = $(id).val(); + } + else if ("checkbox" === $(id).attr("type")) { + //$( "#tests" ).append( "Eco: " + id + " getItem is " + localStorage.getItem( id ) + "\n" ) ; + $(id)[0].checked = JSON.parse(localStorage.getItem(id)); + retrieved = $(id)[0].checked; + } + return retrieved; +} + +var tests_store_retrieve = function tests_store_retrieve() { + if ($("#tests").length !== 0) { + is(1, 1, "one equals one"); + // isnot( 0, 1, "zero differs one" ) ; + + // no exist + is(undefined, store("#test_noexists"), + "store: #test_noexists"); + is(undefined, retrieve("#test_noexists"), + "retrieve: #test_noexists"); + is(undefined, retrieve("#test_noexists2"), + "retrieve: #test_noexists2"); + + // input text + $("#test_text").val("foo"); + is("foo", $("#test_text").val(), "#test_text val = foo"); + is("foo", store("#test_text"), "store: #test_text"); + $("#test_text").val("bar"); + is("bar", $("#test_text").val(), "#test_text val = bar"); + is("foo", retrieve("#test_text"), "retrieve: #test_text = foo"); + is("foo", $("#test_text").val(), "#test_text val = foo"); + + + // input check button + $("#test_checkbox").prop("checked", true); + is(true, store("#test_checkbox"), "store: #test_checkbox checked"); + + $("#test_checkbox").prop("checked", false); + is(true, retrieve("#test_checkbox"), "retrieve: #test_checkbox = true"); + + $("#test_checkbox").prop("checked", false); + is(false, store("#test_checkbox"), "store: #test_checkbox not checked"); + $("#test_checkbox").prop("checked", true); + is(false, retrieve("#test_checkbox"), "retrieve: #test_checkbox = false"); + + } +} + + +var store_form = function store_form() { + if (Storage !== "undefined") { + // Code for localStorage. + store("#user1"); + store("#password1"); + store("#host1"); + store("#subfolder1"); + store("#showpassword1"); + + store("#user2"); + store("#password2"); + store("#host2"); + store("#subfolder2"); + store("#showpassword2"); + + store("#dry"); + store("#justlogin"); + store("#justfolders"); + store("#justfoldersizes"); + + localStorage.account1_background_color = $("#account1").css("background-color"); + localStorage.account2_background_color = $("#account2").css("background-color"); + } +} + +var show_extra_if_needed = function show_extra_if_needed() { + if ($("#subfolder1").length && $("#subfolder1").val().length > 0) { + $(".extra_param").show(); + } + if ($("#subfolder2").length && $("#subfolder2").val().length > 0) { + $(".extra_param").show(); + } +} + +var retrieve_form = function retrieve_form() { + if (Storage !== "undefined") { + // Code for localStorage. + retrieve("#user1"); + retrieve("#password1"); + // retrieve("#showpassword1") ; + retrieve("#host1"); + retrieve("#subfolder1"); + + retrieve("#user2"); + retrieve("#password2"); + // retrieve("#showpassword2") ; + retrieve("#host2"); + retrieve("#subfolder2"); + + retrieve("#dry"); + retrieve("#justlogin"); + retrieve("#justfolders"); + retrieve("#justfoldersizes"); + + // In case, how to restore the original color from css file. + // localStorage.removeItem( "account1_background_color" ) ; + // localStorage.removeItem( "account2_background_color" ) ; + + if (localStorage.account1_background_color) { + $("#account1").css("background-color", + localStorage.account1_background_color); + } + if (localStorage.account2_background_color) { + $("#account2").css("background-color", + localStorage.account2_background_color); + } + + // Show the extra parameters if they are not empty because it would + // be dangerous to retrieve them without showing them + show_extra_if_needed(); + } +} + + +var showpassword = function showpassword(id, button) { + var x = document.getElementById(id); + if (button.checked) { + x.type = "text"; + } else { + x.type = "password"; + } +} + + + +var tests_cryptojs = function tests_cryptojs() { + if ($("#tests").length !== 0) { + if (typeof CryptoJS === 'undefined') { + is(true, typeof CryptoJS !== 'undefined', "CryptoJS is available"); + note("CryptoJS is not available on this site. Ask the admin to fix this.\n"); + } + else if (typeof CryptoJS.SHA256 !== "function") { + is("function", typeof CryptoJS.SHA256, "CryptoJS.SHA256 is a function"); + note("CryptoJS.SHA256 function is not available on this site. Ask the admin to fix this.\n"); + } + else { + // safe to use the function + is("function", typeof CryptoJS.SHA256, "CryptoJS.SHA256 is a function"); + is("2f77668a9dfbf8d5848b9eeb4a7145ca94c6ed9236e4a773f6dcafa5132b2f91", sha256("Message"), "sha256 Message"); + is("26429a356b1d25b7d57c0f9a6d5fed8a290cb42374185887dcd2874548df0779", sha256("caca"), "sha256 caca"); + is("e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855", sha256(""), "sha256 ''"); + is(tmphash(), tmphash(), "tmphash"); + + $("#user1").val("test1"); + $("#password1").val("secret1"); + $("#host1").val("test1.lamiral.info"); + $("#user2").val("test2"); + $("#password2").val("secret2"); + $("#host2").val("test2.lamiral.info"); + is("20d2b4917cf69114876b4c8779af543e89c5871c6ada68107619722e55af1101", tmphash(), "tmphash like testslive"); + $("#user1").val(""); + $("#password1").val(""); + $("#host1").val(""); + $("#user2").val(""); + $("#password2").val(""); + $("#host2").val(""); + + } + } +} + +var sha256 = function sha256(string) { + var hash = CryptoJS.SHA256(string); + var hash_hex = hash.toString(CryptoJS.enc.Hex); + return (hash_hex); +} + +var tmphash = function tmphash() { + var string = ""; + string = string.concat( + $("#user1").val(), $("#password1").val(), $("#host1").val(), + $("#user2").val(), $("#password2").val(), $("#host2").val(), + ) + return (sha256(string)); +} + +var init = function init() { + // in case of a manual refresh, start with + $("#bt-sync").prop("disabled", false); + $("#bt-abort").prop("disabled", false); + $("#progress-bar-left").css("width", 100 + "%").attr("aria-valuenow", 100); + + $("#showpassword1").on('click', function (event) { + var button = event.target; + showpassword("password1", button); + } + ); + + + $("#showpassword2").on('click', function (event) { + //$("#tests").append( "\nthat1=" + JSON.stringify( event.target, undefined, 4 ) ) ; + var button = event.target; + showpassword("password2", button); + } + ); + + + $("#bt-sync").on('click', function () { + $("#bt-sync").prop("disabled", true); + $("#bt-abort").prop("disabled", false); + $("#progress-txt").text("ETA: coming soon"); + store_form(); + imapsync(); + } + ); + + $("#bt-abort").on('click', function () { + $("#bt-sync").prop("disabled", true); + $("#bt-abort").prop("disabled", true); + abort(); + } + ); + + + var swap = function swap(p1, p2) { + var temp = $(p2).val(); + $(p2).val($(p1).val()); + $(p1).val(temp); + }; + + + $("#swap").on('click', function () { + // swaping colors can't use swap() + var temp1 = $("#account1").css("background-color"); + var temp2 = $("#account2").css("background-color"); + $("#account1").css("background-color", temp2); + $("#account2").css("background-color", temp1); + + swap($("#user1"), $("#user2")); + swap($("#password1"), $("#password2")); + swap($("#host1"), $("#host2")); + swap($("#subfolder1"), $("#subfolder2")); + + var temp = $("#showpassword1")[0].checked; + $("#showpassword1")[0].checked = $("#showpassword2")[0].checked; + $("#showpassword2")[0].checked = temp; + showpassword("password1", $("#showpassword1")[0]); + showpassword("password2", $("#showpassword2")[0]); + } + ); + + + +} + +var tests_bilan = function tests_bilan(nb_attended_test) { + // attended number of tests: nb_attended_test + + $("#tests").append("1.." + test.counter_all + "\n"); + if (test.counter_nok > 0) { + $("#tests").append( + "\nFAILED tests \n" + + test.failed_tests + ); + $("#tests").collapse("show"); + } + // Summary of tests: failed 0 tests, run xx tests, + // expected to run yy tests. + if (test.counter_all !== nb_attended_test) { + $("#tests").append("# Looks like you planned " + + nb_attended_test + + " tests but ran " + + test.counter_all + ".\n" + ); + $("#tests").collapse("show"); + } +}; + +var tests = function tests(nb_attended_test) { + if ($("#tests").length !== 0) { + tests_store_retrieve(); + tests_last_eta(); + tests_decompose_eta_line(); + tests_last_x_lines(); + // tests_cryptojs( ) ; + + // The following test can be used to check that if a test fails + // then all the tests are shown to the user. + //is( 0, 1, "this test always fails" ) ; + + tests_bilan(nb_attended_test); + + // If you want to always see the tests, uncomment the following + // line + //$("#tests").collapse("show") ; + + } +} + + + + +$(document).ready( + function () { + "use strict"; + // Bootstrap popover and tooltip + $("[data-toggle='tooltip']").tooltip(); + init(); + //tests(38); + retrieve_form(); + } +); diff --git a/html/imapsync_form_extra.html b/html/imapsync_form_extra.html new file mode 100644 index 0000000..5a8e651 --- /dev/null +++ b/html/imapsync_form_extra.html @@ -0,0 +1,375 @@ + + + + + + + + + + + Imapsync online + + + + + + + + + + + + + + + + + +
+ +

+        
+        
+ + + + +
+
+ +
+
+
+ + Imapsync home + + Top + Bottom +
+
+
+
+

Imapsync online

+

Copy/synchronize a complete mailbox to + another, + without duplicates!

+
+
+ +
+
+
+
+ IMAP source mailbox + + +
+ + +
+ + +
+ + +
+
+ + +
+ + +
+ + + + +
+ +
+ + + + +
+ +
+ +
+ + +
+
+
+
+ +
+ +
+ + +
+ +
+ + + +
+ +
+ + + +
+ +
+ + + +
+ +
+ +
+ +
+ + +
+ +
+ + +
+
+ IMAP destination mailbox + + +
+ + +
+ + +
+ + +
+
+ + +
+ +
+ + + + +
+ +
+ + + +
+ +
+ +
+ + +
+
+ + + +
+
+
+
+
+ + + +
+ + + + + + + + +
+ + + + + +
+
+ +
+
+ +
+
+
+ + +
+ +
ETA: Estimation Time of Arrival
+ +
+
+ Done +
+
+ Todo +
+
+ +
+

Console of imapsync launch

+
+
+
+
+            
+ Bottom of imapsync log +
+ +
+

Console of abort

+
+
+
+
+            
+
+
+ +
+
+

Log of imapsync run

+ +

+
+    
+    
+

Feel free to contact + Gilles LAMIRAL +

+ +
+ + + +
+
+ +
+
+ + + + + + + + + + + + \ No newline at end of file diff --git a/imapsync b/imapsync new file mode 100644 index 0000000..e3f3363 --- /dev/null +++ b/imapsync @@ -0,0 +1,21984 @@ +#!/usr/bin/env perl + +# $Id: imapsync,v 2.229 2022/09/14 18:08:24 gilles Exp gilles $ +# structure +# pod documentation +# use pragmas +# main program +# global variables initialization +# get_options( ) ; +# default values +# folder loop +# subroutines +# sub usage + + +# pod documentation + +=pod + +=head1 NAME + +imapsync - Email IMAP tool for syncing, copying, migrating +and archiving email mailboxes between two imap servers, one way, +and without duplicates. + +=head1 VERSION + +This documentation refers to Imapsync $Revision: 2.229 $ + +=head1 USAGE + + To synchronize the source imap account + "test1" on server "test1.lamiral.info" with password "secret1" + to the destination imap account + "test2" on server "test2.lamiral.info" with password "secret2" + do: + + imapsync \ + --host1 test1.lamiral.info --user1 test1 --password1 secret1 \ + --host2 test2.lamiral.info --user2 test2 --password2 secret2 + +=head1 DESCRIPTION + +We sometimes need to transfer mailboxes from one imap server to +one another. + +Imapsync command is a tool allowing incremental and recursive imap +transfers from one mailbox to another. If you don't understand the +previous sentence, it's normal, it's pedantic computer-oriented +jargon. + +All folders are transferred, recursively, meaning the whole folder +hierarchy is taken, all messages in them, and all message flags (\Seen +\Answered \Flagged etc.) are synced too. + +Imapsync reduces the amount of data transferred by not transferring a +given message if it already resides on the destination side. Messages +that are on the destination side but not on the source side stay as +they are. See the --delete2 option to have strict sync and delete +them. + +How does imapsync know a message is already on both sides? Same +specific headers and the transfer is done only once. By default, the +identification headers are "Message-Id:" and "Received:" lines but +this choice can be changed with the --useheader option, most often a +duplicate problem is solved by using --useheader "Message-Id" + + +All flags are preserved, unread messages will stay unread, read ones +will stay read, deleted will stay deleted. In the IMAP protocol, a +deleted message is not deleted, it is marked \Deleted and can be +undeleted. Real destruction comes with the EXPUNGE or UIDEXPUNGE IMAP +commands. + +You can abort the transfer at any time and restart it later, imapsync +works well with bad connections and interruptions, by design. On a +terminal hit Ctr-c twice within two seconds to abort the program. Hit +Ctr-c just once makes imapsync reconnect to both imap servers. + +How do you know the sync is finished and well done? +When imapsync ends by itself it mentions it with lines like those: + + Exiting with return value 0 (EX_OK: successful termination) 0/50 nb_errors/max_errors PID 301 + Removing pidfile /tmp/imapsync.pid + Log file is LOG_imapsync/2020_11_17_15_59_22_761_test1_test2.txt ( to change it, use --logfile filepath ; or use --nolog to turn off logging ) + +If you don't have those lines it means that either the sync process is +still running (or eventually hanging indefinitely) or that it ended +without a whisper, a strong kill -9 on Linux for example. + +If you have those final lines then it means the sync process is properly +finished. It may have encountered problems though. + +A good synchronization is mentioned by some lines above the last ones, +especially those three lines: + + The sync looks good, all 1745 identified messages in host1 are on host2. + There is no unidentified message on host1. + Detected 0 errors + +Imapsync mentions the total sizes of both accounts at the beginning of +the sync and also at the end. Sometimes, even with a strict sync, +those total sizes differ, and sometimes they differ a lot. The +difference is not a good criterion to conclude the sync went wrong. + +Why? That's because message sizes given by the imap servers are not +always accurate, they are not always the same as the actual message +sizes of the messages transferred by imapsync. Imapsync use the sizes +given by the imap servers to calculate the big total size. They can +differ. In the early days, Imapsync used the sizes of the messages as +one of the criteria to identify the messages, different sizes implied +different messages; but it was a mistake, the same message had +different sizes on both sides sometimes, depending on the imap +servers. + +Another explanation for a big total size difference is that Gmail +doesn't count the size of duplicate messages across folders twice, +while imapsync does. + + +A classical scenario is synchronizing a mailbox B from another mailbox +A where you just want to keep a strict copy of A in B. Strict meaning +all messages in A will be in B but no more. + +For a strict synchronization, use the option --delete2. The option +--delete2 deletes the messages in the host2 folder B that are not in +the host1 folder A. If you also need to destroy host2 folders that are +not in host1 then use --delete2folders. See also --delete2foldersonly +and --delete2foldersbutnot to set up exceptions on folders to +destroy. INBOX will never be destroyed, it's a mandatory folder in +IMAP so imapsync doesn't even try to remove it. + +A different scenario is to delete the messages from the source mailbox +after a successful transfer, it can be a good feature when migrating +mailboxes since messages will be only on one side. The source account +will only have messages that are not on the destination yet, ie, +messages that arrived after a sync or that failed to be transferred. + +In that case, use the --delete1 option. Option --delete1 implies also +the option --expunge1 so all messages marked deleted on host1 will be +deleted. In IMAP protocol deleting a message does not delete it, it +marks it with the flag \Deleted, allowing an undelete. Expunging a +folder removes, definitively, all the messages marked as \Deleted in +this folder. + +You can also decide to remove empty folders once all of their messages +have been transferred. Add --delete1emptyfolders to obtain this +behavior. + +Imapsync is not adequate for maintaining two active imap accounts in +synchronization when the user plays independently on both sides. Use +offlineimap (written by John Goerzen) or mbsync (written by Michael +R. Elkins) for a 2 ways synchronization. + + +=head1 OPTIONS + + usage: imapsync [options] + +The standard options are the six values forming the credentials. +Three values on each side are needed to login into the IMAP +servers. These six values are a hostname, a username, and a password, +two times. + +Here are the conventions used in the following descriptions of the +options: + + str means a string + int means an integer number + flo means a float number + reg means a regular expression + cmd means a command + + --dry : Makes imapsync do nothing for real; it just prints what + would be done without --dry. + +=head2 OPTIONS/credentials + + + --host1 str : Source or "from" imap server. + --port1 int : Port to connect on host1. + Optional since default ports are the + well known ports imap/143 or imaps/993. + --user1 str : User to login on host1. + --password1 str : Password of user1. + + --host2 str : "destination" imap server. + --port2 int : Port to connect on host2. Optional + --user2 str : User to login on host2. + --password2 str : Password of user2. + + --showpasswords : Shows passwords on output instead of "MASKED". + Useful to restart a complete run by just reading + the command line used in the log, + or to debug passwords. + It's not a secure practice at all! + + --passfile1 str : Password file for the user1. It must contain the + password on the first line. This option avoids showing + the password on the command line like --password1 does. + --passfile2 str : Password file for the user2. + +You can also pass the passwords in the environment variables +IMAPSYNC_PASSWORD1 and IMAPSYNC_PASSWORD2. If you don't pass +the user1 password via --password1 nor --passfile1 nor $IMAPSYNC_PASSWORD1 +then imapsync will prompt to enter the password on the terminal. +Same thing for user2 password. + +=head2 OPTIONS/encryption + + --nossl1 : Do not use a SSL connection on host1. + --ssl1 : Use a SSL connection on host1. On by default if possible. + + --nossl2 : Do not use a SSL connection on host2. + --ssl2 : Use a SSL connection on host2. On by default if possible. + + --notls1 : Do not use a TLS connection on host1. + --tls1 : Use a TLS connection on host1. On by default if possible. + + --notls2 : Do not use a TLS connection on host2. + --tls2 : Use a TLS connection on host2. On by default if possible. + + --debugssl int : SSL debug mode from 0 to 4. + + --sslargs1 str : Pass any ssl parameter for host1 ssl or tls connection. Example: + --sslargs1 SSL_verify_mode=1 --sslargs1 SSL_version=SSLv3 + See all possibilities in the new() method of IO::Socket::SSL + http://search.cpan.org/perldoc?IO::Socket::SSL#Description_Of_Methods + --sslargs2 str : Pass any ssl parameter for host2 ssl or tls connection. + See --sslargs1 + + +=head2 OPTIONS/authentication + + --authmech1 str : Auth mechanism to use with host1: + PLAIN, LOGIN, CRAM-MD5 etc. Use UPPERCASE. + --authmech2 str : Auth mechanism to use with host2. See --authmech1 + + --authuser1 str : User to auth with on host1 (admin user). + Avoid using --authmech1 SOMETHING with --authuser1. + --authuser2 str : User to auth with on host2 (admin user). + --proxyauth1 : Use proxyauth on host1. Requires --authuser1. + Required by Sun/iPlanet/Netscape IMAP servers to + be able to use an administrative user. + --proxyauth2 : Use proxyauth on host2. Requires --authuser2. + + --authmd51 : Use MD5 authentication for host1. + --authmd52 : Use MD5 authentication for host2. + --domain1 str : Domain on host1 (NTLM authentication). + --domain2 str : Domain on host2 (NTLM authentication). + + --oauthaccesstoken1 str : The access token to authenticate with OAUTH2. + It will be combined with the --user1 value to form the + string to pass with XOAUTH2 authentication. + The password given by --password1 or --passfile1 + is ignored but needed on the command line. + Instead of the access token itself, the value can be a + file containing the access token on the first line. + If the value is a file, imapsync reads its first line + and take this line as the access token. The advantage + of the file is that if the access token changes then + imapsync can read it again when it needs to reconnect + during a run. + + + --oauthaccesstoken2 str : same thing as --oauthaccesstoken1 + + --oauthdirect1 str : The direct string to pass with XOAUTH2 authentication. + The password given by --password1 or --passfile1 and + the user given by --user1 are ignored but they are + needed to be on the command line. Consider it a bug. + + --oauthdirect2 str : same thing as oauthdirect1 + + +=head2 OPTIONS/folders + + + --folder str : Sync this folder. + --folder str : and this one, etc. + --folderrec str : Sync this folder recursively. + --folderrec str : and this one, etc. + + --folderfirst str : Sync this folder first. Ex. --folderfirst "INBOX" + --folderfirst str : then this one, etc. + --folderlast str : Sync this folder last. --folderlast "[Gmail]/All Mail" + --folderlast str : then this one, etc. + + --nomixfolders : Do not merge folders when host1 is case-sensitive + while host2 is not (like Exchange). Only the first + similar folder is synced. Example: with folders + "Sent", "SENT" and "sent" on host1, only "Sent" + will be synced to host2. + + --skipemptyfolders : Empty host1 folders are not created on host2. + + --include reg : Sync folders matching this regular expression + --include reg : or this one, etc. + If both --include --exclude options are used, then + include is done before. + --exclude reg : Skips folders matching this regular expression + Several folders to avoid: + --exclude 'fold1|fold2|f3' skips fold1, fold2 and f3. + --exclude reg : or this one, etc. + + --automap : guesses folders mapping, for folders well known as + "Sent", "Junk", "Drafts", "All", "Archive", "Flagged". + + --f1f2 str1=str2 : Force folder str1 to be synced to str2, + --f1f2 overrides --automap and --regextrans2. + Use several --f1f2 options to map several folders. + Option --f1f2 is a one to one only folder mapping, + str1 and str2 have to be full path folder names. + + --subfolder2 str : Syncs the whole host1 folders hierarchy under the + host2 folder named str. + It does it internally by adding three + --regextrans2 options before all others. + Add --debug to see what's really going on. + + --subfolder1 str : Syncs the host1 folders hierarchy which is under folder + str to the root hierarchy of host2. + It's the couterpart of a sync done by --subfolder2 + when doing it in the reverse order. + Backup/Restore scenario: + Use --subfolder2 str for a backup to the folder str + on host2. Then use --subfolder1 str for restoring + from the folder str, after inverting + host1/host2 user1/user2 values. + + + --subscribed : Transfers subscribed folders. + --subscribe : Subscribe to the folders transferred on the + host2 that are subscribed on host1. On by default. + --subscribeall : Subscribe to the folders transferred on the + host2 even if they are not subscribed on host1. + + --prefix1 str : Remove prefix str to all destination folders, + usually "INBOX." or "INBOX/" or an empty string "". + imapsync guesses the prefix if host1 imap server + does not have NAMESPACE capability. So this option + should not be used most of the time. + --prefix2 str : Add prefix to all host2 folders. See --prefix1 + + --sep1 str : Host1 separator. This option should not be used + most of the time. + Imapsync gets the separator from the server itself, + by using NAMESPACE, or it tries to guess it + from the folders listing (it counts + characters / . \\ \ in folder names and choose the + more frequent, or finally / if nothing is found. + --sep2 str : Host2 separator. See --sep1 + + --regextrans2 reg : Apply the whole regex to each destination folders. + --regextrans2 reg : and this one. etc. + When you play with the --regextrans2 option, first + add also the safe options --dry --justfolders + Then, when happy, remove --dry for a run, then + remove --justfolders for the next ones. + Have in mind that --regextrans2 is applied after + the automatic prefix and separator inversion. + For examples see: + https://imapsync.lamiral.info/FAQ.d/FAQ.Folders_Mapping.txt + +=head2 OPTIONS/folders sizes + + --nofoldersizes : Do not calculate the size of each folder at the + beginning of the sync. Default is to calculate them. + --nofoldersizesatend: Do not calculate the size of each folder at the + end of the sync. Default is to calculate them. + --justfoldersizes : Exit after having printed the initial folder sizes. + + +=head2 OPTIONS/tmp + + + --tmpdir str : Where to store temporary files and subdirectories. + Will be created if it doesn't exist. + Default is system specific, Unix is /tmp but + /tmp is often too small and deleted at reboot. + --tmpdir /var/tmp should be better. + + --pidfile str : The file where imapsync pid is written, + it can be dirname/filename complete path. + The default name is imapsync.pid in tmpdir. + + --pidfilelocking : Abort if pidfile already exists. Useful to avoid + concurrent transfers on the same mailbox. + + +=head2 OPTIONS/log + + --nolog : Turn off logging on file + --logfile str : Change the default log filename (can be dirname/filename). + --logdir str : Change the default log directory. Default is LOG_imapsync/ + +The default logfile name is for example + + LOG_imapsync/2019_12_22_23_57_59_532_user1_user2.txt + +where: + + 2019_12_22_23_57_59_532 is nearly the date of the start + YYYY_MM_DD_HH_MM_SS_mmm + year_month_day_hour_minute_second_millisecond + +and user1 user2 are the --user1 --user2 values. + +=head2 OPTIONS/messages + + --skipmess reg : Skips messages matching the regex. + Example: 'm/[\x80-\xff]/' # to avoid 8bits messages. + --skipmess is applied before --regexmess + --skipmess reg : or this one, etc. + + --skipcrossduplicates : Avoid copying messages that are already copied + in another folder, good from Gmail to XYZ when + XYZ is not also Gmail. + Activated with --gmail1 unless --noskipcrossduplicates + + --debugcrossduplicates : Prints which messages (UIDs) are skipped with + --skipcrossduplicates and in what other folders + they are. + + --pipemess cmd : Apply this cmd command to each message content + before the copy. + --pipemess cmd : and this one, etc. + With several --pipemess, the output of each cmd + command (STDOUT) is given to the input (STDIN) + of the next command. + For example, + --pipemess cmd1 --pipemess cmd2 --pipemess cmd3 + is like a Unix pipe: + "cat message | cmd1 | cmd2 | cmd3" + + --disarmreadreceipts : Disarms read receipts (host2 Exchange issue) + + --regexmess reg : Apply the whole regex to each message before transfer. + Example: 's/\000/ /g' # to replace null characters + by spaces. + --regexmess reg : and this one, etc. + + --truncmess int : truncates messages when their size exceed the int + value, specified in bytes. Good to sync too big + messages or to "suppress" attachments. + Have in mind that this way, messages become + uncoherent somehow. + +=head2 OPTIONS/labels + +Gmail present labels as folders in imap. Imapsync can accelerate the sync +by syncing X-GM-LABELS, it will avoid to transfer messages when they are +already on host2 in another folder. + + + --synclabels : Syncs also Gmail labels when a message is copied to host2. + Activated by default with --gmail1 --gmail2 unless + --nosynclabels is added. + + --resynclabels : Resyncs Gmail labels when a message is already on host2. + Activated by default with --gmail1 --gmail2 unless + --noresynclabels is added. + +For Gmail syncs, see also: +https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt + +=head2 OPTIONS/flags + + If you encounter flag problems see also: + https://imapsync.lamiral.info/FAQ.d/FAQ.Flags.txt + + --regexflag reg : Apply the whole regex to each flags list. + Example: 's/"Junk"//g' # to remove "Junk" flag. + --regexflag reg : then this one, etc. + + --resyncflags : Resync flags for already transferred messages. + On by default. + --noresyncflags : Do not resync flags for already transferred messages. + May be useful when a user has already started to play + with its host2 account. + + --filterbuggyflags : Filter flags known to be buggy and generators of errors + "BAD Invalid system flag" or "NO APPEND Invalid flag list". + +=head2 OPTIONS/deletions + + --delete1 : Deletes messages on host1 server after a successful + transfer. Option --delete1 has the following behavior: + it marks messages as deleted with the IMAP flag + \Deleted, then messages are really deleted with an + EXPUNGE IMAP command. If expunging after each message + slows down too much the sync then use + --noexpungeaftereach to speed up, expunging will then be + done only twice per folder, one at the beginning and + one at the end of a folder sync. + + --expunge1 : Expunge messages on host1 just before syncing a folder. + Expunge is done per folder. + Expunge aims is to really delete messages marked deleted. + An expunge is also done after each message copied + if option --delete1 is set (unless --noexpungeaftereach). + + --noexpunge1 : Do not expunge messages on host1. + + --delete1emptyfolders : Deletes empty folders on host1, INBOX excepted. + Useful with --delete1 since what remains on host1 + is only what failed to be synced. + + --delete2 : Delete messages in the host2 account that are not in + the host1 account. Useful for backup or pre-sync. + --delete2 implies --uidexpunge2 + + --delete2duplicates : Deletes messages in host2 that are duplicates in host2. + Works only without --useuid since duplicates are + detected with an header part of each message. + NB: --delete2duplicates is far less violent than --delete2 + since it removes only duplicates. + + --delete2folders : Delete folders in host2 that are not in host1. + For safety, first try it like this, it is safe: + --delete2folders --dry --justfolders --nofoldersizes + and see what folders will be deleted. + + --delete2foldersonly reg : Delete only folders matching the regex reg. + Example: --delete2foldersonly "/^Junk$|^INBOX.Junk$/" + This option activates --delete2folders + + --delete2foldersbutnot reg : Do not delete folders matching the regex rex. + Example: --delete2foldersbutnot "/Tasks$|Contacts$|Foo$/" + This option activates --delete2folders + + --noexpunge2 : Do not expunge messages on host2. + --nouidexpunge2 : Do not uidexpunge messages on the host2 account + that are not on the host1 account. + + +=head2 OPTIONS/dates + + If you encounter problems with dates, see also: + https://imapsync.lamiral.info/FAQ.d/FAQ.Dates.txt + + --syncinternaldates : Sets the internal dates on host2 as the same as host1. + Turned on by default. Internal date is the date + a message arrived on a host (Unix mtime usually). + --idatefromheader : Sets the internal dates on host2 as same as the + ones in "Date:" headers. + + + +=head2 OPTIONS/message selection + + --maxsize int : Skip messages larger (or equal) than int bytes + --minsize int : Skip messages smaller (or equal) than int bytes + + --maxage int : Skip messages older than int days. + final stats (skipped) don't count older messages + see also --minage + --minage int : Skip messages newer than int days. + final stats (skipped) don't count newer messages + You can do (+ zone are the messages selected): + past|----maxage+++++++++++++++>now + past|+++++++++++++++minage---->now + past|----maxage+++++minage---->now (intersection) + past|++++minage-----maxage++++>now (union) + + --search str : Selects only messages returned by this IMAP SEARCH + command. Applied on both sides. + For a complete set of what can be search see + https://imapsync.lamiral.info/FAQ.d/FAQ.Messages_Selection.txt + + --search1 str : Same as --search but for selecting host1 messages only. + --search2 str : Same as --search but for selecting host2 messages only. + So --search CRIT equals --search1 CRIT --search2 CRIT + + --noabletosearch : Makes --minage and --maxage options use the internal + dates given by a FETCH imap command instead of the + "Date:" header. Internal date is the arrival date + in the mailbox. + --noabletosearch equals --noabletosearch1 --noabletosearch2 + + --noabletosearch1 : Like --noabletosearch but for host1 only. + --noabletosearch2 : Like --noabletosearch but for host2 only. + + --maxlinelength int : skip messages with a line length longer than int bytes. + RFC 2822 says it must be no more than 1000 bytes but + real life servers and email clients do more. + + + --useheader str : Use this header to compare messages on both sides. + Example: "Message-Id" or "Received" or "Date". + --useheader str and this one, etc. + + --syncduplicates : Sync also duplicates. Off by default. + + --usecache : Use cache to speed up next syncs. Off by default. + --nousecache : Do not use cache. Caveat: --useuid --nousecache creates + duplicates on multiple runs. + + --useuid : Use UIDs instead of headers as a criterion to recognize + messages. Option --usecache is then implied unless + --nousecache is used. + + +=head2 OPTIONS/miscellaneous + + --syncacls : Synchronizes acls (Access Control Lists). + Acls in IMAP are not standardized, be careful + since one acl code on one side may signify something + else on the other one. + --nosyncacls : Does not synchronize acls. This is the default. + + --addheader : When a message has no headers to be identified, + --addheader adds a "Message-Id" header, + like "Message-Id: 12345@imapsync", where 12345 + is the imap UID of the message on the host1 folder. + Useful to sync folders "Sent" or "Draft". + + +=head2 OPTIONS/debugging + + --debug : Debug mode. + --debugfolders : Debug mode for the folders part only. + --debugcontent : Debug content of the messages transferred. Huge output. + --debugflags : Debug mode for flags. + --debugimap1 : IMAP debug mode for host1. Very verbose. + --debugimap2 : IMAP debug mode for host2. Very verbose. + --debugimap : IMAP debug mode for host1 and host2. Twice very verbose. + --debugmemory : Debug mode showing memory consumption after each copy. + + --errorsmax int : Exit when int number of errors is reached. Default is 50. + + --tests : Run local non-regression tests. Exit code 0 means all ok. + --testslive : Run a live test with test1.lamiral.info imap server. + Useful to check the basics. Needs internet connection. + --testslive6 : Run a live test with ks6ipv6.lamiral.info imap server. + Useful to check the ipv6 connectivity. Needs internet. + + +=head2 OPTIONS/specific + + --gmail1 : sets --host1 to Gmail and other options. See FAQ.Gmail.txt + --gmail2 : sets --host2 to Gmail and other options. See FAQ.Gmail.txt + + --office1 : sets --host1 to Office365 and other options. See FAQ.Office365.txt + --office2 : sets --host2 to Office365 and other options. See FAQ.Office365.txt + + --exchange1 : sets options for Exchange. See FAQ.Exchange.txt + --exchange2 : sets options for Exchange. See FAQ.Exchange.txt + + --domino1 : sets options for Domino. See FAQ.Domino.txt + --domino2 : sets options for Domino. See FAQ.Domino.txt + + +=head2 OPTIONS/behavior + + --timeout1 flo : Connection timeout in seconds for host1. + Default is 120 and 0 means no timeout at all. + --timeout2 flo : Connection timeout in seconds for host2. + Default is 120 and 0 means no timeout at all. + + Caveat, under CGI context, you may encounter a timeout + from the webserver, killing imapsync and the imap connections. + See the document INSTALL.OnlineUI.txt and search + for "Timeout" for how to deal with this issue. + + --keepalive1 : https://metacpan.org/pod/Mail::IMAPClient#Keepalive + Some firewalls and network gears like to timeout connections + prematurely if the connection sits idle. + This option enables SO_KEEPALIVE on the host1 socket. + --keepalive1 is on by default since imapsync release 2.169 + Use --nokeepalive1 to disable it. + + --keepalive2 : Same as --keepalive2 but for host2. + Use --nokeepalive2 to disable it. + + --maxmessagespersecond flo : limits the average number of messages + transferred per second. + + --maxbytespersecond int : limits the average transfer rate per second. + --maxbytesafter int : starts --maxbytespersecond limitation only after + --maxbytesafter amount of data transferred. + + --maxsleep flo : do not sleep more than int seconds. + On by default, 2 seconds max, like --maxsleep 2 + + --abort : terminates a previous call still running. + It uses the pidfile to know what process to abort. + + --exitwhenover int : Stop syncing and exits when int total bytes + transferred is reached. + + --version : Print only the software version. + --noreleasecheck : Do not check for any new imapsync release. + --releasecheck : Check for new imapsync release. + it's an http request to + http://imapsync.lamiral.info/prj/imapsync/VERSION + + --emailreport1 : Put the email final report in host1 INBOX + --emailreport2 : Put the email final report in host2 INBOX + + --noemailreport1 : Do not put the email final report in host1 INBOX + --noemailreport2 : Do not put the email final report in host2 INBOX + + --noid : Do not send/receive IMAP "ID" command to imap servers. + + --justconnect : Just connect to both servers and print useful + information. Need only --host1 and --host2 options. + Obsolete since "imapsync --host1 imaphost" alone + implies --justconnect + + --justlogin : Just login to both host1 and host2 with users + credentials, then exit. + + --justfolders : Do only things about folders (ignore messages). + + --help : print this help. + + Example: to synchronize imap account "test1" on "test1.lamiral.info" + to imap account "test2" on "test2.lamiral.info" + with test1 password "secret1" + and test2 password "secret2" + + imapsync \ + --host1 test1.lamiral.info --user1 test1 --password1 secret1 \ + --host2 test2.lamiral.info --user2 test2 --password2 secret2 + + +=cut +# comment + +=pod + + + +=head1 SECURITY + +You can use --passfile1 instead of --password1 to mention the password +since it is safer. With --password1 option, on Linux, any user on your +host can see the password by using the 'ps auxwwww' command. Using a +variable (like IMAPSYNC_PASSWORD1) is also dangerous because of the +'ps auxwwwwe' command. So, saving the password in a well protected +file (600 or rw-------) is the best solution. + +Imapsync activates ssl or tls encryption by default, if possible. + +What detailed behavior is under this "if possible"? + +Imapsync activates ssl if the well known port imaps port (993) is open +on the imap servers. If the imaps port is closed then it open a normal +(clear) connection on port 143 but it looks for TLS support in the +CAPABILITY list of the servers. If TLS is supported then imapsync goes +to encryption with STARTTLS. + +If the automatic ssl and the tls detections fail then imapsync will +not protect against sniffing activities on the network, especially for +passwords. + +If you want to force ssl or tls just use --ssl1 --ssl2 or --tls1 +--tls2 + +See also the document FAQ.Security.txt in the FAQ.d/ directory or at +https://imapsync.lamiral.info/FAQ.d/FAQ.Security.txt + +=head1 EXIT STATUS + +Imapsync will exit with a 0 status (return code) if everything went +good. Otherwise, it exits with a non-zero status. That's classical +Unix behavior. Here is the list of the exit code values (an integer +between 0 and 255). In Bourne Shells, this exit code value can be +retrieved within the variable value "$?" if you read it just after the +imapsync call. + +The names reflect their meaning: + +=for comment +egrep '^Readonly my.*\$EX' imapsync | egrep -o 'EX.*' | sed 's_^_ _' + + EX_OK => 0 ; #/* successful termination */ + EX_USAGE => 64 ; #/* command line usage error */ + EX_NOINPUT => 66 ; #/* cannot open input */ + EX_UNAVAILABLE => 69 ; #/* service unavailable */ + EX_SOFTWARE => 70 ; #/* internal software error */ + EXIT_CATCH_ALL => 1 ; # Any other error + EXIT_BY_SIGNAL => 6 ; # Should be 128+n where n is the sig_num + EXIT_BY_FILE => 7 ; + EXIT_PID_FILE_ERROR => 8 ; + EXIT_CONNECTION_FAILURE => 10 ; + EXIT_TLS_FAILURE => 12 ; + EXIT_AUTHENTICATION_FAILURE => 16 ; + EXIT_SUBFOLDER1_NO_EXISTS => 21 ; + EXIT_WITH_ERRORS => 111 ; + EXIT_WITH_ERRORS_MAX => 112 ; + EXIT_OVERQUOTA => 113 ; + EXIT_ERR_APPEND => 114 ; + EXIT_ERR_FETCH => 115 ; + EXIT_ERR_CREATE => 116 ; + EXIT_ERR_SELECT => 117 ; + EXIT_TRANSFER_EXCEEDED => 118 ; + EXIT_ERR_APPEND_VIRUS => 119 ; + EXIT_TESTS_FAILED => 254 ; # Like Test::More API + EXIT_CONNECTION_FAILURE_HOST1 => 101 ; + EXIT_CONNECTION_FAILURE_HOST2 => 102 ; + EXIT_AUTHENTICATION_FAILURE_USER1 => 161 ; + EXIT_AUTHENTICATION_FAILURE_USER2 => 162 ; + + +=head1 LICENSE AND COPYRIGHT + +Imapsync is free, open, public but not always gratis software cover by +the NOLIMIT Public License, now called NLPL. See the LICENSE file +included in the distribution or just read the following simple +sentence as it IS the license text: + + "No limits to do anything with this work and this license." + +In case it is not long enough, I repeat: + + "No limits to do anything with this work and this license." + +Look at https://imapsync.lamiral.info/LICENSE + +=head1 AUTHOR + +Gilles LAMIRAL + +Good feedback is always welcome. +Bad feedback is very often welcome. + +Gilles LAMIRAL earns his living by writing, installing, configuring +and sometimes teaching free, open, and often gratis software. Imapsync +used to be "always gratis" but now it is only "often gratis" because +imapsync is sold by its author, your servitor, a good way to maintain +and support free open public software tools over decades. + +=head1 BUGS AND LIMITATIONS + +See https://imapsync.lamiral.info/FAQ.d/FAQ.Reporting_Bugs.txt + +=head1 IMAP SERVERS supported + +See https://imapsync.lamiral.info/S/imapservers.shtml + +=head1 HUGE MIGRATION + +If you have many mailboxes to migrate think about a little shell +program. Write a file called file.txt (for example) containing users +and passwords. The separator used in this example is ';' + +The file.txt file contains: + +user001_1;password001_1;user001_2;password001_2 +user002_1;password002_1;user002_2;password002_2 +user003_1;password003_1;user003_2;password003_2 +user004_1;password004_1;user004_2;password004_2 +user005_1;password005_1;user005_2;password005_2 +... + +On Unix the shell program can be: + + { while IFS=';' read u1 p1 u2 p2; do + imapsync --host1 imap.side1.org --user1 "$u1" --password1 "$p1" \ + --host2 imap.side2.org --user2 "$u2" --password2 "$p2" ... + done ; } < file.txt + +On Windows the batch program can be: + + FOR /F "tokens=1,2,3,4 delims=; eol=#" %%G IN (file.txt) DO imapsync ^ + --host1 imap.side1.org --user1 %%G --password1 %%H ^ + --host2 imap.side2.org --user2 %%I --password2 %%J ... + +The ... have to be replaced by nothing or any imapsync option. +Welcome in shell or batch programming ! + +You will find already written scripts at +https://imapsync.lamiral.info/examples/ + +=head1 INSTALL + + Imapsync works under any Unix with Perl. + + Imapsync works under most Windows (2000, XP, Vista, Seven, Eight, Ten + and all Server releases 2000, 2003, 2008 and R2, 2012 and R2, 2016) + as a standalone binary software called imapsync.exe, usually launched + from a batch file in order to avoid always typing the options. There + is also a 32bit binary called imapsync_32bit.exe + + Imapsync works under OS X as a standalone binary software called + imapsync_bin_Darwin + + Purchase latest imapsync at + https://imapsync.lamiral.info/ + + You'll receive a link to a compressed tarball called + imapsync-x.xx.tgz where x.xx is the version number. + Untar the tarball where you want (on Unix): + + tar xzvf imapsync-x.xx.tgz + + Go into the directory imapsync-x.xx and read the INSTALL file. + As mentioned at https://imapsync.lamiral.info/#install + the INSTALL file can also be found at + https://imapsync.lamiral.info/INSTALL.d/INSTALL.ANY.txt + It is now split in several files for each system + https://imapsync.lamiral.info/INSTALL.d/ + +=head1 CONFIGURATION + +There is no specific configuration file for imapsync, everything is +specified by the command line parameters and the default behavior. + + +=head1 HACKING + +Feel free to hack imapsync as the NOLIMIT license permits it. + + +=head1 SIMILAR SOFTWARE + + See also https://imapsync.lamiral.info/S/external.shtml + for a better up to date list. + +List verified on Friday July 1, 2021. + + imapsync: https://github.com/imapsync/imapsync (this is an imapsync copy, sometimes delayed, with --noreleasecheck by default since release 1.592, 2014/05/22) + imap_tools: https://web.archive.org/web/20161228145952/http://www.athensfbc.com/imap_tools/. The imap_tools code is now at https://github.com/andrewnimmo/rick-sanders-imap-tools + imaputils: https://github.com/mtsatsenko/imaputils (very old imap_tools fork) + Doveadm-Sync: https://wiki2.dovecot.org/Tools/Doveadm/Sync ( Dovecot sync tool ) + davmail: http://davmail.sourceforge.net/ + offlineimap: http://offlineimap.org/ + fdm: https://github.com/nicm/fdm + mbsync: http://isync.sourceforge.net/ + mailsync: http://mailsync.sourceforge.net/ + mailutil: https://www.washington.edu/imap/ part of the UW IMAP toolkit. (well, seems abandoned now) + imaprepl: https://bl0rg.net/software/ http://freecode.com/projects/imap-repl/ + imapcopy (Pascal): http://www.ardiehl.de/imapcopy/ + imapcopy (Java): https://code.google.com/archive/p/imapcopy/ + imapsize: http://www.broobles.com/imapsize/ + migrationtool: http://sourceforge.net/projects/migrationtool/ + imapmigrate: http://sourceforge.net/projects/cyrus-utils/ + larch: https://github.com/rgrove/larch (derived from wonko_imapsync, good at Gmail) + wonko_imapsync: http://wonko.com/article/554 (superseded by larch) + pop2imap: http://www.linux-france.org/prj/pop2imap/ (I wrote that too) + exchange-away: http://exchange-away.sourceforge.net/ + SyncBackPro: http://www.2brightsparks.com/syncback/sbpro.html + ImapSyncClient: https://github.com/ridaamirini/ImapSyncClient + MailStore: https://www.mailstore.com/en/products/mailstore-home/ + mnIMAPSync: https://github.com/manusa/mnIMAPSync + imap-upload: http://imap-upload.sourceforge.net/ (A tool for uploading a local mbox file to IMAP4 server) + imapbackup: https://github.com/rcarmo/imapbackup (A Python script for incremental backups of IMAP mailboxes) + BitRecover email-backup 99 USD, 299 USD https://www.bitrecover.com/email-backup/. + ImportExportTools: https://addons.thunderbird.net/en-us/thunderbird/addon/importexporttools/ ImportExportTools for Mozilla Thunderbird by Paolo Kaosmos. ImportExportTools does not do IMAP. + rximapmail: https://sourceforge.net/projects/rximapmail/ + CodeTwo: https://www.codetwo.com/ but CodeTwo does imap source to Office365 only. + +=head1 HISTORY + +I initially wrote imapsync in July 2001 because an enterprise, called +BaSystemes, paid me to install a new imap server without losing huge +old mailboxes located in a far away remote imap server, accessible by +an often broken low-bandwidth ISDN link. + +I had to verify every mailbox was well transferred, all folders, all +messages, without wasting bandwidth or creating duplicates upon +resyncs. The imapsync design was made with the beautiful rsync command +in mind. + +Imapsync started its life as a patch of the copy_folder.pl script. The +script copy_folder.pl comes from the Mail-IMAPClient-2.1.3 perl module +tarball source (more precisely in the examples/ directory of the +Mail-IMAPClient tarball). + +So many changes happened since then that I wonder if it remains any +lines of the original copy_folder.pl in imapsync source code. + + +=cut + + +# use pragmas +# + +use strict ; +use warnings ; +use Carp ; +use Cwd ; +use Compress::Zlib ; +use Data::Dumper ; +use Digest::HMAC_SHA1 qw( hmac_sha1 hmac_sha1_hex ) ; +use Digest::MD5 qw( md5 md5_hex md5_base64 ) ; +use Encode ; +use Encode::IMAPUTF7 ; +use English qw( -no_match_vars ) ; +use Errno qw(EAGAIN EPIPE ECONNRESET) ; +use Fcntl ; +use File::Basename ; +use File::Copy::Recursive ; +use File::Glob qw( :glob ) ; +use File::Path qw( mkpath rmtree ) ; +use File::Spec ; +use File::stat ; +use Getopt::Long ( ) ; +use IO::File ; +use IO::Socket qw( :crlf SOL_SOCKET SO_KEEPALIVE ) ; +use IO::Socket::INET6 ; +use IO::Socket::SSL ; +use IO::Tee ; +use IPC::Open3 'open3' ; +#use locale ; +use Mail::IMAPClient 3.30 ; +use MIME::Base64 ; +use Pod::Usage qw(pod2usage) ; +use POSIX qw( uname SIGALRM :sys_wait_h ) ; +use Sys::Hostname ; +use Term::ReadKey ; +use Test::More ; +use Time::HiRes qw( time sleep ) ; +use Time::Local ; +use Unicode::String ; +use Readonly ; +use Sys::MemInfo ; +use Regexp::Common ; +use Text::ParseWords ; # for quotewords() +use File::Tail ; + + + +local $OUTPUT_AUTOFLUSH = 1 ; + +# constants + +# Let us do like sysexits.h +# /usr/include/sysexits.h +# and https://www.tldp.org/LDP/abs/html/exitcodes.html + +# Should avoid 2 126 127 128..128+64=192 255 +# Should use 0 1 3..125 193..254 + +Readonly my $EX_OK => 0 ; #/* successful termination */ +Readonly my $EX_USAGE => 64 ; #/* command line usage error */ +#Readonly my $EX_DATAERR => 65 ; #/* data format error */ +Readonly my $EX_NOINPUT => 66 ; #/* cannot open input */ +#Readonly my $EX_NOUSER => 67 ; #/* addressee unknown */ +#Readonly my $EX_NOHOST => 68 ; #/* host name unknown */ +Readonly my $EX_UNAVAILABLE => 69 ; #/* service unavailable */ +Readonly my $EX_SOFTWARE => 70 ; #/* internal software error */ +#Readonly my $EX_OSERR => 71 ; #/* system error (e.g., can't fork) */ +#Readonly my $EX_OSFILE => 72 ; #/* critical OS file missing */ +#Readonly my $EX_CANTCREAT => 73 ; #/* can't create (user) output file */ +#Readonly my $EX_IOERR => 74 ; #/* input/output error */ +#Readonly my $EX_TEMPFAIL => 75 ; #/* temp failure; user is invited to retry */ +#Readonly my $EX_PROTOCOL => 76 ; #/* remote error in protocol */ +#Readonly my $EX_NOPERM => 77 ; #/* permission denied */ +#Readonly my $EX_CONFIG => 78 ; #/* configuration error */ + +# Mine +Readonly my $EXIT_CATCH_ALL => 1 ; # Any other error +Readonly my $EXIT_BY_SIGNAL => 6 ; # Should be 128+n where n is the sig_num +Readonly my $EXIT_BY_FILE => 7 ; +Readonly my $EXIT_PID_FILE_ERROR => 8 ; +Readonly my $EXIT_CONNECTION_FAILURE => 10 ; +Readonly my $EXIT_TLS_FAILURE => 12 ; +Readonly my $EXIT_AUTHENTICATION_FAILURE => 16 ; +Readonly my $EXIT_SUBFOLDER1_NO_EXISTS => 21 ; +Readonly my $EXIT_WITH_ERRORS => 111 ; +Readonly my $EXIT_WITH_ERRORS_MAX => 112 ; +Readonly my $EXIT_OVERQUOTA => 113 ; +Readonly my $EXIT_ERR_APPEND => 114 ; +Readonly my $EXIT_ERR_FETCH => 115 ; +Readonly my $EXIT_ERR_CREATE => 116 ; +Readonly my $EXIT_ERR_SELECT => 117 ; +Readonly my $EXIT_TRANSFER_EXCEEDED => 118 ; + +Readonly my $EXIT_ERR_APPEND_VIRUS => 119 ; +Readonly my $EXIT_ERR_FLAGS => 120 ; + +Readonly my $EXIT_TESTS_FAILED => 254 ; # Like Test::More API + +Readonly my $EXIT_CONNECTION_FAILURE_HOST1 => 101 ; +Readonly my $EXIT_CONNECTION_FAILURE_HOST2 => 102 ; +Readonly my $EXIT_AUTHENTICATION_FAILURE_USER1 => 161 ; +Readonly my $EXIT_AUTHENTICATION_FAILURE_USER2 => 162 ; + + +Readonly my %EXIT_TXT => ( + $EX_OK => 'EX_OK: successful termination', + $EX_USAGE => 'EX_USAGE: command line usage error', + $EX_NOINPUT => 'EX_NOINPUT: cannot open input', + $EX_UNAVAILABLE => 'EX_UNAVAILABLE: service unavailable', + $EX_SOFTWARE => 'EX_SOFTWARE: internal software error', + + $EXIT_CATCH_ALL => 'EXIT_CATCH_ALL', + $EXIT_BY_SIGNAL => 'EXIT_BY_SIGNAL', + $EXIT_BY_FILE => 'EXIT_BY_FILE', + $EXIT_PID_FILE_ERROR => 'EXIT_PID_FILE_ERROR' , + $EXIT_CONNECTION_FAILURE => 'EXIT_CONNECTION_FAILURE', + $EXIT_TLS_FAILURE => 'EXIT_TLS_FAILURE', + $EXIT_AUTHENTICATION_FAILURE => 'EXIT_AUTHENTICATION_FAILURE', + $EXIT_SUBFOLDER1_NO_EXISTS => 'EXIT_SUBFOLDER1_NO_EXISTS', + $EXIT_WITH_ERRORS => 'EXIT_WITH_ERRORS', + $EXIT_WITH_ERRORS_MAX => 'EXIT_WITH_ERRORS_MAX', + $EXIT_OVERQUOTA => 'EXIT_OVERQUOTA', + $EXIT_ERR_APPEND => 'EXIT_ERR_APPEND', + $EXIT_ERR_APPEND_VIRUS => 'EXIT_ERR_APPEND_VIRUS', + $EXIT_ERR_FETCH => 'EXIT_ERR_FETCH', + $EXIT_ERR_FLAGS => 'EXIT_ERR_FLAGS', + $EXIT_ERR_CREATE => 'EXIT_ERR_CREATE', + $EXIT_ERR_SELECT => 'EXIT_ERR_SELECT', + $EXIT_TESTS_FAILED => 'EXIT_TESTS_FAILED', + $EXIT_TRANSFER_EXCEEDED => 'EXIT_TRANSFER_EXCEEDED', + $EXIT_CONNECTION_FAILURE_HOST1 => 'EXIT_CONNECTION_FAILURE_HOST1', + $EXIT_CONNECTION_FAILURE_HOST2 => 'EXIT_CONNECTION_FAILURE_HOST2', + $EXIT_AUTHENTICATION_FAILURE_USER1 => 'EXIT_AUTHENTICATION_FAILURE_USER1', + $EXIT_AUTHENTICATION_FAILURE_USER2 => 'EXIT_AUTHENTICATION_FAILURE_USER2', +) ; + + +Readonly my %EXIT_VALUE_OF_ERR_TYPE => ( + ERR_APPEND_SIZE => $EXIT_ERR_APPEND, + ERR_OVERQUOTA => $EXIT_OVERQUOTA, + ERR_APPEND => $EXIT_ERR_APPEND, + ERR_APPEND_VIRUS => $EXIT_ERR_APPEND_VIRUS, + ERR_CREATE => $EXIT_ERR_CREATE, + ERR_SELECT => $EXIT_ERR_SELECT, + ERR_Host1_FETCH => $EXIT_ERR_FETCH, + ERR_FLAGS => $EXIT_ERR_FLAGS, + ERR_UNCLASSIFIED => $EXIT_WITH_ERRORS, + ERR_NOTHING_REPORTED => $EXIT_WITH_ERRORS, + ERR_TRANSFER_EXCEEDED => $EXIT_TRANSFER_EXCEEDED, + ERR_CONNECTION_FAILURE_HOST1 => $EXIT_CONNECTION_FAILURE_HOST1, + ERR_CONNECTION_FAILURE_HOST2 => $EXIT_CONNECTION_FAILURE_HOST2, + ERR_AUTHENTICATION_FAILURE_USER1 => $EXIT_AUTHENTICATION_FAILURE_USER1, + ERR_AUTHENTICATION_FAILURE_USER2 => $EXIT_AUTHENTICATION_FAILURE_USER2, + ERR_EXIT_TLS_FAILURE => $EXIT_TLS_FAILURE, +) ; + + + +Readonly my %COMMENT_OF_ERR_TYPE => ( + ERR_APPEND_SIZE => \&comment_err_append_size, + ERR_OVERQUOTA => \&comment_err_overquota, + ERR_APPEND => \&comment_err_blank, + ERR_APPEND_VIRUS => \&comment_err_blank, + ERR_CREATE => \&comment_err_blank, + ERR_SELECT => \&comment_err_blank, + ERR_Host1_FETCH => \&comment_err_blank, + ERR_FLAGS => \&comment_err_flags, + ERR_UNCLASSIFIED => \&comment_err_blank, + ERR_NOTHING_REPORTED => \&comment_err_blank, + ERR_TRANSFER_EXCEEDED => \&comment_err_transfer_exceeded, + ERR_CONNECTION_FAILURE_HOST1 => \&comment_err_connection_failure_host1, + ERR_CONNECTION_FAILURE_HOST2 => \&comment_err_connection_failure_host2, + ERR_AUTHENTICATION_FAILURE_USER1 => \&comment_err_authentication_failure_host1, + ERR_AUTHENTICATION_FAILURE_USER2 => \&comment_err_authentication_failure_host2, + ERR_EXIT_TLS_FAILURE => \&comment_err_blank, +) ; + + +sub comment_err_blank +{ + return '' ; +} + + +sub comment_err_append_size +{ + my $mysync = shift @ARG ; + + my $comment = "The destination server refuses too big messages. Use --truncmess option. Read https://imapsync.lamiral.info/FAQ.d/FAQ.Messages_Too_Big.txt" ; + return $comment ; +} + + +sub comment_err_authentication_failure_host1 +{ + my $mysync = shift @ARG ; + + my $comment = "Check the credentials for $mysync->{ user1 }." ; + return $comment ; +} + +sub comment_err_authentication_failure_host2 +{ + my $mysync = shift @ARG ; + + my $comment = "Check the credentials for $mysync->{ user2 }." ; + return $comment ; +} + + +sub comment_err_connection_failure_host1 +{ + my $mysync = shift @ARG ; + + my $comment = "Check that host1 $mysync->{ host1 } on port $mysync->{ port1 } is the right IMAP server to be contacted for your mailbox." ; + return $comment ; +} + +sub comment_err_connection_failure_host2 +{ + my $mysync = shift @ARG ; + + my $comment = "Check that host1 $mysync->{ host2 } on port $mysync->{ port2 } is the right IMAP server to be contacted for your mailbox." ; + return $comment ; +} + +sub comment_err_overquota +{ + my $mysync = shift @ARG ; + + my $comment = 'The destination mailbox is 100% full, get free space on it and then resume the sync.' ; + return $comment ; +} + + +sub comment_err_transfer_exceeded +{ + my $mysync = shift @ARG ; + + my $size_limit_human = bytes_display_string_dec( $mysync->{ exitwhenover } ) ; + my $comment = "The maximum transfer size for a single sync is reached ( over $size_limit_human ). Relaunch the sync to sync more." ; + return $comment ; +} + +sub comment_err_flags +{ + my $mysync = shift @ARG ; + + my $comment = 'Many STORE errors with FLAGS. Retry with the option --noresyncflags' ; + return $comment ; +} + + + +Readonly my $DEFAULT_LOGDIR => 'LOG_imapsync' ; + +Readonly my $ERRORS_MAX => 50 ; # exit after 50 errors. +Readonly my $ERRORS_MAX_CGI => 500 ; # exit after 500 errors in CGI context. + +Readonly my $INTERVAL_TO_EXIT => 2 ; # interval max to exit instead of reconnect + +Readonly my $SPLIT => 100 ; # By default, 100 at a time, not more. +Readonly my $SPLIT_FACTOR => 10 ; # init_imap() calls Maxcommandlength( $SPLIT_FACTOR * $split ) + # which means default Maxcommandlength is 10*100 = 1000 characters ; + +Readonly my $IMAP_PORT => 143 ; # Well know port for IMAP +Readonly my $IMAP_SSL_PORT => 993 ; # Well know port for IMAP over SSL + +Readonly my $LAST => -1 ; +Readonly my $MINUS_ONE => -1 ; +Readonly my $MINUS_TWO => -2 ; + +Readonly my $RELEASE_NUMBER_EXAMPLE_1 => '1.351' ; +Readonly my $RELEASE_NUMBER_EXAMPLE_2 => 42.4242 ; + +Readonly my $TCP_PING_TIMEOUT => 5 ; +Readonly my $DEFAULT_TIMEOUT => 120 ; +Readonly my $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND => 3 ; + +Readonly my $DEFAULT_BUFFER_SIZE => 4096 ; + +Readonly my $MAX_SLEEP => 2 ; # 2 seconds max for limiting too long sleeps from --maxbytespersecond and --maxmessagespersecond + +Readonly my $DEFAULT_EXPIRATION_TIME_OAUTH2_PK12 => 3600 ; + +Readonly my $PERMISSION_FILTER => 7777 ; + +Readonly my $KIBI => 1024 ; + +Readonly my $NUMBER_10 => 10 ; +Readonly my $NUMBER_42 => 42 ; +Readonly my $NUMBER_100 => 100 ; +Readonly my $NUMBER_200 => 200 ; +Readonly my $NUMBER_300 => 300 ; +Readonly my $NUMBER_123456 => 123_456 ; +Readonly my $NUMBER_654321 => 654_321 ; + +Readonly my $NUMBER_20_000 => 20_000 ; + +Readonly my $QUOTA_PERCENT_LIMIT => 90 ; + +Readonly my $NUMBER_104_857_600 => 104_857_600 ; + +Readonly my $SIZE_MAX_STR => 64 ; + +Readonly my $NB_SECONDS_IN_A_DAY => 86_400 ; + +Readonly my $STD_CHAR_PER_LINE => 80 ; + +Readonly my $TRUE => 1 ; +Readonly my $FALSE => 0 ; + +Readonly my $LAST_RESSORT_SEPARATOR => q{/} ; + +Readonly my $CGI_TMPDIR_TOP => '/var/tmp/imapsync_cgi' ; +Readonly my $CGI_HASHFILE => '/var/tmp/imapsync_hash' ; +Readonly my $UMASK_PARANO => '0077' ; + +Readonly my $STR_use_releasecheck => q{Check if a new imapsync release is available by adding --releasecheck} ; + +Readonly my $GMAIL_MAXSIZE => 35_651_584 ; + +Readonly my $FORCE => 1 ; + +# if ( 'MSWin32' eq $OSNAME ) +# if ( 'darwin' eq $OSNAME ) +# if ( 'linux' eq $OSNAME ) + + + +# global variables +# Currently working to finish with only $sync, $acc1, $acc2 +# Not finished yet... + +my( + $sync, $acc1, $acc2, + $debugdev, $debugmaxlinelength, $debugcgi, + @include, @exclude, @folderrec, + @folderfirst, @folderlast, + @h1_folders_all, %h1_folders_all, + @h2_folders_all, %h2_folders_all, + @h2_folders_from_1_wanted, %h2_folders_from_1_all, + %requested_folder, + $h1_folders_wanted_nb, $h1_folders_wanted_ct, + @h2_folders_not_in_1, + %h1_subscribed_folder, %h2_subscribed_folder, + %h2_folders_from_1_wanted, + %h2_folders_from_1_several, + $prefix1, $prefix2, + @regexmess, @skipmess, @pipemess, $pipemesscheck, + $syncflagsaftercopy, + $syncinternaldates, + $idatefromheader, + $minsize, $maxage, $minage, + $search, + @useheader, %useheader, + $skipsize, $allowsizemismatch, $buffersize, + $authmd5, $authmd51, $authmd52, + $subscribed, $subscribe, $subscribeall, + $help, + $nb_msg_skipped_dry_mode, + $h2_nb_msg_noheader, + $h1_bytes_processed, + $h1_nb_msg_end, $h1_bytes_end, + $h2_nb_msg_end, $h2_bytes_end, + $timestart_int, + $uid1, $uid2, + $split1, $split2, + $modulesversion, + $delete2folders, $delete2foldersonly, $delete2foldersbutnot, + $debugcache, $cacheaftercopy, + $wholeheaderifneeded, %h1_msgs_copy_by_uid, $useuid, $h2_uidguess, + $checkmessageexists, + $messageidnodomain, + $fixInboxINBOX, + $maxlinelength, $maxlinelengthcmd, + $minmaxlinelength, + $fixcolonbug, + $create_folder_old, + $disarmreadreceipts, + $mixfolders, + $fetch_hash_set, + $cgidir, + %month_abrev, + $SSL_VERIFY_POLICY, +) ; + +exit( single_sync( $sync, $acc1, $acc2 ) ) ; + + + +sub single_sync +{ + +# main program +# global variables initialization + +# I'm currently removing all global variables except $sync $acc1 $acc2 +# passing each of them under +# $sync->{variable_name} +# or $acc1->{variable_name} +# or $acc1->{variable_name} + +# +$acc1 = {} ; +$acc2 = {} ; +$sync->{ acc1 } = $acc1 ; +$sync->{ acc2 } = $acc2 ; + +$acc1->{ Side } = 'Host1' ; +$acc2->{ Side } = 'Host2' ; +$acc1->{ N } = '1' ; +$acc2->{ N } = '2' ; + +$sync->{timestart} = time ; # Is a float because of use Time::HiRres + +$sync->{rcs} = q{$Id: imapsync,v 2.229 2022/09/14 18:08:24 gilles Exp gilles $} ; + +$sync->{ memory_consumption_at_start } = memory_consumption_of_myself( ) || 0 ; + + +my @loadavg = loadavg( ) ; + +$sync->{ total_bytes_transferred } = 0 ; +$sync->{ total_bytes_skipped } = 0 ; +$sync->{ nb_msg_transferred } = 0 ; +$sync->{ nb_msg_skipped } = $nb_msg_skipped_dry_mode = 0 ; + +$sync->{ acc1 }->{ nb_msg_deleted } = 0 ; +$sync->{ acc2 }->{ nb_msg_deleted } = 0 ; + +$sync->{ acc1 }->{ nb_msg_duplicate } = 0 ; +$sync->{ acc2 }->{ nb_msg_duplicate } = 0 ; + +$sync->{ h1_nb_msg_noheader } = 0 ; +$h2_nb_msg_noheader = 0 ; + + +$sync->{ h1_nb_msg_start } = 0 ; +$sync->{ h1_bytes_start } = 0 ; +$sync->{ h2_nb_msg_start } = 0 ; +$sync->{ h2_bytes_start } = 0 ; +$sync->{ h1_nb_msg_processed } = $h1_bytes_processed = 0 ; + +$sync->{ h2_nb_msg_crossdup } = 0 ; + +#$h1_nb_msg_end = $h1_bytes_end = 0 ; +#$h2_nb_msg_end = $h2_bytes_end = 0 ; + +$sync->{ nb_errors } = 0; +$sync->{ biggest_message_transferred } = 0; + +%month_abrev = ( + Jan => '00', + Feb => '01', + Mar => '02', + Apr => '03', + May => '04', + Jun => '05', + Jul => '06', + Aug => '07', + Sep => '08', + Oct => '09', + Nov => '10', + Dec => '11', +); + +# Just create a CGI object if under cgi context only. +# Needed for the get_options() call +cgibegin( $sync ) ; + +# In cgi context, printing must start by the header so we delay other prints by using output() storage +my $options_good = get_options( $sync, @ARGV ) ; + +$sync->{ cpu_number } = cpu_number( ) ; +$sync->{ heavy_load_reached } = heavy_load_reached( $sync ) ; + +$sync->{ loadavg } = join( q{ }, $loadavg[ 0 ] ) + . " on $sync->{cpu_number} cores and " + . ram_memory_info( $sync ) ; + +# Is it the first myprint? +cgibuildheader( $sync ) ; +docker_context( $sync ) ; + +print_output_if_needed( $sync ) ; +output_reset_with( $sync ) ; + + +# don't go on if options are not all known. +if ( ! defined $options_good ) { exit $EX_USAGE ; } + +# If you want releasecheck not to be done by default (like the github maintainer), +# then just uncomment the first "$sync->{releasecheck} =" line, the line ending with "0 ;", +# the second line (ending with "1 ;") can then stay active or be commented, +# the result will be the same: no releasecheck by default (because 0 is then the defined value). + +$sync->{releasecheck} = defined $sync->{releasecheck} ? $sync->{releasecheck} : 0 ; +#$sync->{releasecheck} = defined $sync->{releasecheck} ? $sync->{releasecheck} : 1 ; + +# just the version +if ( $sync->{ version } ) { + myprint( imapsync_version( $sync ), "\n" ) ; + return 0 ; +} + +#$sync->{debugenv} = 1 ; +$sync->{debugenv} and printenv( $sync ) ; # if option --debugenv +load_modules( ) ; + +# after_get_options call usage and exit if --help or options were not well got +after_get_options( $sync, $options_good ) ; + +#local $ENV{TZ} = 'GMT' if ( under_cgi_context( $sync ) and 'MSWin32' ne $OSNAME ) ; +#output( $sync, localtime(time) . " " . gmtime(time) . "\n" ) ; + +make_var_array_to_a_hash( $sync ) ; + + +# Under CGI environment, fix caveat emptor potential issues +cgisetcontext( $sync ) ; + +get_options_extra( $sync ) ; + +# --gmail --gmail --exchange --office etc. +easyany( $sync ) ; + + +$sync->{ sanitize } = defined $sync->{ sanitize } ? $sync->{ sanitize } : 1 ; +sanitize( $sync ) ; + +$sync->{ tmpdir } ||= File::Spec->tmpdir( ) ; + +# Unit tests +my $unittestssuite = unittestssuite( $sync ) ; + + +if ( condition_to_leave_after_tests( $sync ) ) +{ + return $unittestssuite ; +} + +# init live varaiables + +if ( $sync->{ testslive } ) +{ + testslive_init( $sync ) ; +} + +if ( $sync->{ testslive6 } ) +{ + testslive6_init( $sync ) ; +} + +define_pidfile( $sync ) ; +if ( $sync->{ abortbyfile } ) { $sync->{ abort } = 1 ; } + +install_signals( $sync ) ; + +$sync->{ loglogfilename } = '../list_all_logs_auto.txt' ; +$sync->{ log } = defined $sync->{ log } ? $sync->{ log } : 1 ; + +$sync->{ errorsdump } = defined $sync->{ errorsdump } ? $sync->{ errorsdump } : 1 ; +$sync->{ errorsmax } = defined $sync->{ errorsmax } ? $sync->{ errorsmax } : $ERRORS_MAX ; + +$sync->{ emailreport1 } = defined $sync->{ emailreport1 } ? $sync->{ emailreport1 } : 0 ; +$sync->{ emailreport2 } = defined $sync->{ emailreport2 } ? $sync->{ emailreport2 } : 0 ; + + +# log and output +binmode STDOUT, ":encoding(UTF-8)" ; + + +if ( $sync->{ log } ) { + $sync->{ logdir } = setlogdir( $sync ) ; + $sync->{ logfile } = setlogfile( $sync, $sync->{ logfile } ) ; + $sync->{ tee } = teelaunch( $sync, $sync->{ logfile } ) ; + # now $sync->{tee} is a filehandle to STDOUT and the logfile +} + +#binmode STDERR, ":encoding(UTF-8)" ; +# STDERR goes to the same place: LOG and STDOUT if logging is on +# or just STDOUT +# + +stderr_to_stdout( $sync ) ; + + +if ( usecache_and_skipcrossduplicates( $sync ) ) +{ + $sync->{ nb_errors }++ ; + exit_clean( $sync, $EX_USAGE, "Error: can not have both --usecache and --skipcrossduplicates\n" ) ; +} + + + +$timestart_int = int( $sync->{timestart} ) ; +$sync->{timebefore} = $sync->{timestart} ; + + +$sync->{ timestart_str } = localtimez( $sync->{timestart} ) ; + +# The prints in the log starts here + +myprint( localhost_info( $sync ), "\n" ) ; +myprint( "Transfer started at $sync->{ timestart_str }\n" ) ; +myprint( "PID is $PROCESS_ID my PPID is ", mygetppid( ), "\n" ) ; +announcelogfile( $sync ) ; +myprint( "Load is " . ( join( q{ }, loadavg( ) ) || 'unknown' ), " on $sync->{cpu_number} cores\n" ) ; +#myprintf( "Memory consumption so far: %.1f MiB\n", memory_consumption_of_myself( ) / $KIBI / $KIBI ) ; +myprint( 'Current directory is ' . getcwd( ) . "\n" ) ; +myprint( 'Real user id is ' . getpwuid_any_os( $REAL_USER_ID ) . " (uid $REAL_USER_ID)\n" ) ; +myprint( 'Effective user id is ' . getpwuid_any_os( $EFFECTIVE_USER_ID ). " (euid $EFFECTIVE_USER_ID)\n" ) ; + +$modulesversion = defined $modulesversion ? $modulesversion : 1 ; + +$sync->{ warn_release } = ( $sync->{ releasecheck } ) ? check_last_release( ) : $STR_use_releasecheck ; + + +$wholeheaderifneeded = defined $wholeheaderifneeded ? $wholeheaderifneeded : 1; + +# Activate --usecache if --useuid is set and there is no --nousecache +$sync->{ usecache } = 1 if ( $useuid and ( ! defined $sync->{ usecache } ) ) ; +$cacheaftercopy = 1 if ( $sync->{ usecache } and ( ! defined $cacheaftercopy ) ) ; + +$sync->{ checkfoldersexist } = defined $sync->{ checkfoldersexist } ? $sync->{ checkfoldersexist } : 1 ; +$checkmessageexists = defined $checkmessageexists ? $checkmessageexists : 0 ; +$sync->{ expungeaftereach } = defined $sync->{ expungeaftereach } ? $sync->{ expungeaftereach } : 1 ; + +# abletosearch is on by default +$sync->{abletosearch} = defined $sync->{abletosearch} ? $sync->{abletosearch} : 1 ; +$sync->{abletosearch1} = defined $sync->{abletosearch1} ? $sync->{abletosearch1} : $sync->{abletosearch} ; +$sync->{abletosearch2} = defined $sync->{abletosearch2} ? $sync->{abletosearch2} : $sync->{abletosearch} ; +$checkmessageexists = 0 if ( not $sync->{abletosearch1} ) ; + + +$sync->{ trylogin } = defined $sync->{ trylogin } ? $sync->{ trylogin } : 1 ; +$sync->{showpasswords} = defined $sync->{showpasswords} ? $sync->{showpasswords} : 0 ; +$sync->{ fixslash2 } = defined $sync->{ fixslash2 } ? $sync->{ fixslash2 } : 1 ; +$fixInboxINBOX = defined $fixInboxINBOX ? $fixInboxINBOX : 1 ; +$create_folder_old = defined $create_folder_old ? $create_folder_old : 0 ; +$mixfolders = defined $mixfolders ? $mixfolders : 1 ; +$sync->{automap} = defined $sync->{automap} ? $sync->{automap} : 0 ; + +$sync->{ delete2duplicates } = determine_delete2duplicates( $sync ) ; + + +$sync->{maxmessagespersecond} = defined $sync->{maxmessagespersecond} ? $sync->{maxmessagespersecond} : 0 ; +$sync->{maxbytespersecond} = defined $sync->{maxbytespersecond} ? $sync->{maxbytespersecond} : 0 ; + +$sync->{sslcheck} = defined $sync->{sslcheck} ? $sync->{sslcheck} : 1 ; + +myprint( banner_imapsync( $sync, @ARGV ) ) ; + +myprint( "Temp directory is $sync->{ tmpdir } ( to change it use --tmpdir dirpath )\n" ) ; + +myprint( output( $sync ) ) ; +output_reset_with( $sync ) ; + +do_valid_directory( $sync->{ tmpdir } ) || croak "Error creating tmpdir $sync->{ tmpdir } : $OS_ERROR" ; + +remove_pidfile_not_running( $sync->{ pidfile } ) ; + +# if another imapsync is running then tail -f its logfile and exit +# useful in cgi context +if ( $sync->{ tail } and tail( $sync ) ) +{ + exit_clean( $sync, $EX_OK, "Tail -f finished. Now finishing myself processus $PROCESS_ID\n" ) ; + exit $EX_OK ; +} + +if ( ! write_pidfile( $sync ) ) { + myprint( "Exiting with return value $EXIT_PID_FILE_ERROR ($EXIT_TXT{$EXIT_PID_FILE_ERROR}) $sync->{nb_errors}/$sync->{errorsmax} nb_errors/max_errors PID $PROCESS_ID\n" ) ; + exit $EXIT_PID_FILE_ERROR ; +} + + +# New place for abort +# abort before simulong in order to be able to abort a simulong sync +if ( $sync->{ abort } ) +{ + abort( $sync ) ; + # well, the abort job is done, because even when not succeeded + # in aborting another run, this run has to end without doing any + # thing else + + exit $EX_OK ; +} + +if ( $sync->{ memorystress } ) { tests_memory_stress() ; } + + +# simulong is just a loop printing some lines for xx seconds with option "--simulong xx". +simulong( $sync ) ; + + + +# New place for cgi_exit_on_heavy_load 2019_03_03 +# because I want to log it +# Can break here if load is too heavy +# Have in mind the CGI header has already a 503 Service Unavailable printed. +cgi_exit_on_heavy_load( $sync ) ; + + +$fixcolonbug = defined $fixcolonbug ? $fixcolonbug : 1 ; + +if ( $sync->{ usecache } and $fixcolonbug ) { tmpdir_fix_colon_bug( $sync ) } ; + +$modulesversion and myprint( "Modules version list ( use --no-modulesversion to turn off printing this Perl modules list ):\n", modulesversion(), "\n" ) ; + + +check_lib_version( $sync ) or + croak "imapsync needs perl lib Mail::IMAPClient release 3.30 or superior.\n"; + + + +if ( $sync->{ justbanner } ) +{ + myprint( "Exiting because of --justbanner\n" ) ; + exit_clean( $sync, $EX_OK ) ; +} + +# turn on RFC standard flags correction like \SEEN -> \Seen +$sync->{ flagscase } = defined $sync->{ flagscase } ? $sync->{ flagscase } : 1 ; + +# Use PERMANENTFLAGS if available +$sync->{ filterflags } = defined $sync->{ filterflags } ? $sync->{ filterflags } : 1 ; + +filterbuggyflags( $sync ) ; + + +# sync flags just after an APPEND, some servers ignore the flags given in the APPEND +# like MailEnable IMAP server. +# Off by default since it takes time. +$syncflagsaftercopy = defined $syncflagsaftercopy ? $syncflagsaftercopy : 0 ; + +# update flags on host2 for already transferred messages +$sync->{resyncflags} = defined $sync->{resyncflags} ? $sync->{resyncflags} : 1 ; +if ( $sync->{resyncflags} ) { + myprint( "Info: will resync flags for already transferred messages. Use --noresyncflags to not resync flags.\n" ) ; +}else{ + myprint( "Info: will not resync flags for already transferred messages. Use --resyncflags to resync flags.\n" ) ; +} + + +sslcheck( $sync ) ; +#print Data::Dumper->Dump( [ \$sync ] ) ; + +$split1 ||= $SPLIT ; +$split2 ||= $SPLIT ; + +#$sync->{host1} || missing_option( $sync, '--host1' ) ; +$sync->{host1} = sanitize_host( $sync->{host1} ) ; +$sync->{port1} ||= ( $sync->{ssl1} ) ? $IMAP_SSL_PORT : $IMAP_PORT ; + +#$sync->{host2} || missing_option( $sync, '--host2' ) ; +$sync->{host2} = sanitize_host( $sync->{host2} ) ; +$sync->{port2} ||= ( $sync->{ssl2} ) ? $IMAP_SSL_PORT : $IMAP_PORT ; + + +$acc1->{ debugimap } = $acc2->{ debugimap } = 1 if ( $sync->{ debugimap } ) ; +# Set on debug mode if one of the imap dialogs are in debug. +# imap dialog without the debug mode is scary and useless. +$sync->{ debug } = 1 if ( $acc1->{ debugimap } or $acc2->{ debugimap } ) ; + +# By default, don't take size to compare +$skipsize = (defined $skipsize) ? $skipsize : 1; + +$uid1 = defined $uid1 ? $uid1 : 1; +$uid2 = defined $uid2 ? $uid2 : 1; + +$subscribe = defined $subscribe ? $subscribe : 1; + +# Allow size mismatch by default +$allowsizemismatch = defined $allowsizemismatch ? $allowsizemismatch : 1; + + +if ( defined $delete2foldersbutnot or defined $delete2foldersonly ) { + $delete2folders = 1 ; +} + + +my %SSL_VERIFY_STR ; + +Readonly $SSL_VERIFY_POLICY => IO::Socket::SSL::SSL_VERIFY_NONE( ) ; +Readonly %SSL_VERIFY_STR => ( + IO::Socket::SSL::SSL_VERIFY_NONE( ) => 'SSL_VERIFY_NONE, ie, do not check the server certificate.' , + IO::Socket::SSL::SSL_VERIFY_PEER( ) => 'SSL_VERIFY_PEER, ie, check the server certificate.' , +) ; + +$IO::Socket::SSL::DEBUG = defined( $sync->{debugssl} ) ? $sync->{debugssl} : 1 ; + + +if ( $sync->{ssl1} or $sync->{ssl2} or $sync->{tls1} or $sync->{tls2}) { + myprint( "SSL debug mode level is --debugssl $IO::Socket::SSL::DEBUG (can be set from 0 meaning no debug to 4 meaning max debug)\n" ) ; +} + +if ( $sync->{ssl1} ) { + myprint( qq{Host1: SSL default mode is like --sslargs1 "SSL_verify_mode=$SSL_VERIFY_POLICY", meaning for host1 $SSL_VERIFY_STR{$SSL_VERIFY_POLICY}\n} ) ; + myprint( 'Host1: Use --sslargs1 SSL_verify_mode=' . IO::Socket::SSL::SSL_VERIFY_PEER( ) . " to have $SSL_VERIFY_STR{IO::Socket::SSL::SSL_VERIFY_PEER( )} of host1\n" ) ; + # $sync->{ acc1 }->{sslargs}->{SSL_verify_mode} +} + +if ( $sync->{ssl2} ) { + myprint( qq{Host2: SSL default mode is like --sslargs2 "SSL_verify_mode=$SSL_VERIFY_POLICY", meaning for host2 $SSL_VERIFY_STR{$SSL_VERIFY_POLICY}\n} ) ; + myprint( 'Host2: Use --sslargs2 SSL_verify_mode=' . IO::Socket::SSL::SSL_VERIFY_PEER( ) . " to have $SSL_VERIFY_STR{IO::Socket::SSL::SSL_VERIFY_PEER( )} of host2\n" ) ; +} + +# ID on by default since 1.832 +$sync->{id} = defined $sync->{id} ? $sync->{id} : 1 ; + +if ( $sync->{justconnect} + or not $sync->{user1} + or not $sync->{user2} + or not $sync->{host1} + or not $sync->{host2} + ) +{ + my $justconnect = justconnect( $sync ) ; + + myprint( debugmemory( $sync, " after justconnect() call" ) ) ; + exit_clean( $sync, $EX_OK, + "Exiting after a justconnect on host(s): $justconnect\n" + ) ; +} + + +#$sync->{user1} || missing_option( $sync, '--user1' ) ; +#$sync->{user2} || missing_option( $sync, '--user2' ) ; + +$syncinternaldates = defined $syncinternaldates ? $syncinternaldates : 1; + +# Turn on expunge if there is not explicit option --noexpunge1 and option +# --delete1 is given. +# Done because --delete1 --noexpunge1 is very dangerous on the second run: +# the Deleted flag is then synced to all previously transferred messages. +# So --delete1 implies --expunge1 is a better usability default behavior. +if ( $sync->{ delete1 } ) { + if ( ! defined $sync->{ expunge1 } ) { + myprint( "Info: turning on --expunge1 because --delete1 --noexpunge1 is very dangerous on the second run.\n" ) ; + $sync->{ expunge1 } = 1 ; + } + myprint( "Info: if expunging after each message slows down too much the sync then use --noexpungeaftereach to speed up\n" ) ; +} + +if ( $sync->{ uidexpunge2 } and not Mail::IMAPClient->can( 'uidexpunge' ) ) { + myprint( "Failure: uidexpunge not supported (IMAPClient release < 3.17), use nothing or --expunge2 instead\n" ) ; + $sync->{nb_errors}++ ; + exit_clean( $sync, $EX_SOFTWARE ) ; +} + +if ( ( $sync->{ delete2 } or $sync->{ delete2duplicates } ) and not defined $sync->{ uidexpunge2 } ) { + if ( Mail::IMAPClient->can( 'uidexpunge' ) ) { + myprint( "Info: will act as --uidexpunge2\n" ) ; + $sync->{ uidexpunge2 } = 1 ; + }elsif ( not defined $sync->{ expunge2 } ) { + myprint( "Info: will act as --expunge2 (no uidexpunge support)\n" ) ; + $sync->{ expunge2 } = 1 ; + } +} + +if ( $sync->{ delete1 } and $sync->{ delete2 } ) { + myprint( "Warning: using --delete1 and --delete2 together is almost always a bad idea. " + . "You should probably launch two runs, the first with --delete2 for a strict sync, " + . "then the second with --delete1 to remove messages from the source account. " + . "Exiting imapsync.\n" ) ; + $sync->{ nb_errors }++ ; + exit_clean( $sync, $EX_USAGE ) ; +} + +if ( $idatefromheader ) { + myprint( 'Turned ON idatefromheader, ', + "will set the internal dates on host2 from the 'Date:' header line.\n" ) ; + $syncinternaldates = 0 ; +} + +if ( $syncinternaldates ) { + myprint( 'Info: turned ON syncinternaldates, ', + "will set the internal dates (arrival dates) on host2 same as host1.\n" ) ; +}else{ + myprint( "Info: turned OFF syncinternaldates\n" ) ; +} + +if ( defined $authmd5 and $authmd5 ) { + $authmd51 = 1 ; + $authmd52 = 1 ; +} + +if ( defined $authmd51 and $authmd51 ) { + $acc1->{ authmech } ||= 'CRAM-MD5' ; +} +else{ + $acc1->{ authmech } ||= $acc1->{ authuser } ? 'PLAIN' : 'LOGIN' ; +} + +if ( defined $authmd52 and $authmd52 ) { + $acc2->{ authmech } ||= 'CRAM-MD5'; +} +else{ + $acc2->{ authmech } ||= $acc2->{ authuser } ? 'PLAIN' : 'LOGIN'; +} + +$acc1->{ authmech } = uc $acc1->{ authmech } ; +$acc2->{ authmech } = uc $acc2->{ authmech } ; + +if ( defined $acc1->{ proxyauth } && !$acc1->{ authuser } ) +{ + missing_option( $sync, 'With --proxyauth1, --authuser1' ) ; +} + +if ( defined $acc2->{ proxyauth } && !$acc2->{ authuser } ) +{ + missing_option( $sync, 'With --proxyauth2, --authuser2' ) ; +} + +myprint( "Host1: will try to use $acc1->{ authmech } authentication on host1\n") ; +myprint( "Host2: will try to use $acc2->{ authmech } authentication on host2\n") ; + +$sync->{ timeout } = defined $sync->{ timeout } ?$sync->{ timeout } : $DEFAULT_TIMEOUT ; + +$sync->{ acc1 }->{timeout} = defined $sync->{ acc1 }->{timeout} ? $sync->{ acc1 }->{timeout} : $sync->{ timeout } ; +myprint( "Host1: imap connection timeout is $sync->{ acc1 }->{timeout} seconds\n") ; +$sync->{ acc2 }->{timeout} = defined $sync->{ acc2 }->{timeout} ? $sync->{ acc2 }->{timeout} : $sync->{ timeout } ; +myprint( "Host2: imap connection timeout is $sync->{ acc2 }->{timeout} seconds\n" ) ; + + +keepalive1( $sync ) ; +keepalive2( $sync ) ; + + +if ( under_cgi_context( $sync ) ) +{ + myprint( "Under CGI context, a timeout can occur from the webserver, see https://imapsync.lamiral.info/INSTALL.d/INSTALL.OnlineUI.txt\n" ) ; +} + +$sync->{ syncacls } = defined $sync->{ syncacls } ? $sync->{ syncacls } : 0 ; + +# No folders sizes at the beginning if --justfolders, unless really wanted. +if ( + $sync->{ justfolders } + and not defined $sync->{ foldersizes } + and not $sync->{ justfoldersizes } ) +{ + $sync->{ foldersizes } = 0 ; + $sync->{ foldersizesatend } = 1 ; +} + +$sync->{ foldersizes } = ( defined $sync->{ foldersizes } ) ? $sync->{ foldersizes } : 1 ; +$sync->{ foldersizesatend } = ( defined $sync->{ foldersizesatend } ) ? $sync->{ foldersizesatend } : $sync->{ foldersizes } ; + +#$sync->{ checknoabletosearch } = ( defined $sync->{ checknoabletosearch } ) ? $sync->{ checknoabletosearch } : 1 ; +set_checknoabletosearch( $sync ) ; + + +$acc1->{ fastio } = defined $acc1->{ fastio } ? $acc1->{ fastio } : 0 ; +$acc2->{ fastio } = defined $acc2->{ fastio } ? $acc2->{ fastio } : 0 ; + + +$acc1->{ reconnectretry } = defined $acc1->{ reconnectretry } ? $acc1->{ reconnectretry } : $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; +$acc2->{ reconnectretry } = defined $acc2->{ reconnectretry } ? $acc2->{ reconnectretry } : $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; + +# IMAP compression on by default +#$acc1->{ compress } = defined $acc1->{ compress } ? $acc1->{ compress } : 0 ; +#$acc2->{ compress } = defined $acc2->{ compress } ? $acc2->{ compress } : 0 ; + + + +if ( ! @useheader ) { @useheader = qw( Message-Id Received ) ; } + +# Make a hash %useheader of each --useheader 'key' in uppercase +for ( @useheader ) { $sync->{useheader}->{ uc $_ } = undef } ; + +#myprint( Data::Dumper->Dump( [ \%useheader ] ) ) ; +#exit ; + +myprint( "Host1: IMAP server [$sync->{host1}] port [$sync->{port1}] user [$sync->{user1}]\n" ) ; +myprint( "Host2: IMAP server [$sync->{host2}] port [$sync->{port2}] user [$sync->{user2}]\n" ) ; + +get_password1( $sync ) ; +get_password2( $sync ) ; + +# --dry1 make imapsync not fetching messages from host1, it is on when --dry is on. +# Use --dry --nodry1 to make imapsync fetching messages from host1, +# It is useful when debugging transformation options like --pipemess or --regexmess +$sync->{dry1} = defined $sync->{dry1} ? $sync->{dry1} : $sync->{dry} ; + +$sync->{dry_message} = q{} ; +if( $sync->{dry} ) { + $sync->{dry_message} = "\t(not really since --dry mode)" ; +} + +$sync->{ search1 } ||= $search if ( $search ) ; +$sync->{ search2 } ||= $search if ( $search ) ; + +if ( $disarmreadreceipts ) +{ + push @regexmess, q{s{\A((?:[^\n]+\r\n)+|)(^Disposition-Notification-To:[^\n]*\n)(\r?\n|.*\n\r?\n)}{$1X-$2$3}ims} ; +} + +$pipemesscheck = ( defined $pipemesscheck ) ? $pipemesscheck : 1 ; + +if ( @pipemess and $pipemesscheck ) { + myprint( 'Checking each --pipemess command, ' + . join( q{, }, @pipemess ) + . ", with an space string. ( Can avoid this check with --nopipemesscheck )\n" ) ; + my $string = pipemess( q{ }, @pipemess ) ; + # string undef means something was bad. + if ( not ( defined $string ) ) { + $sync->{nb_errors}++ ; + exit_clean( $sync, $EX_USAGE, + "Error: one of --pipemess command is bad, check it\n" + ) ; + } + myprint( "Ok with each --pipemess @pipemess\n" ) ; +} + +if ( $maxlinelengthcmd ) { + myprint( "Checking --maxlinelengthcmd command, + $maxlinelengthcmd, with an space string.\n" + ) ; + my $string = pipemess( q{ }, $maxlinelengthcmd ) ; + # string undef means something was bad. + if ( not ( defined $string ) ) { + $sync->{nb_errors}++ ; + exit_clean( $sync, $EX_USAGE, + "Error: --maxlinelengthcmd command is bad, check it\n" + ) ; + } + myprint( "Ok with --maxlinelengthcmd $maxlinelengthcmd\n" ) ; +} + +if ( @regexmess ) { + my $string = regexmess( q{ } ) ; + myprint( "Checking each --regexmess command with an space string.\n" ) ; + # string undef means one of the eval regex was bad. + if ( not ( defined $string ) ) { + #errors_incr( $sync, 'Warning: one of --regexmess option may be bad, check them' ) ; + exit_clean( $sync, $EX_USAGE, + "Error: one of --regexmess option is bad, check it\n" + ) ; + } + myprint( "Ok with each --regexmess\n" ) ; +} + +if ( @skipmess ) { + myprint( "Checking each --skipmess command with an space string.\n" ) ; + my $match = skipmess( q{ } ) ; + # match undef means one of the eval regex was bad. + if ( not ( defined $match ) ) { + $sync->{nb_errors}++ ; + exit_clean( $sync, $EX_USAGE, + "Error: one of --skipmess option is bad, check it\n" + ) ; + } + myprint( "Ok with each --skipmess\n" ) ; +} + +if ( $sync->{ regexflag } ) { + myprint( "Checking each --regexflag command with an space string.\n" ) ; + my $string = regexflags( $sync, q{ } ) ; + # string undef means one of the eval regex was bad. + if ( not ( defined $string ) ) { + $sync->{nb_errors}++ ; + exit_clean( $sync, $EX_USAGE, + "Error: one of --regexflag option is bad, check it\n" + ) ; + } + myprint( "Ok with each --regexflag\n" ) ; +} + +$sync->{imap1} = login_imap( $sync->{host1}, $sync->{port1}, $sync->{user1}, $sync->{password1}, + $sync->{ssl1}, $sync->{tls1}, + $uid1, $split1, $sync->{ acc1 }, $sync ) ; + +$sync->{imap2} = login_imap( $sync->{host2}, $sync->{port2}, $sync->{user2}, $sync->{password2}, + $sync->{ssl2}, $sync->{tls2}, + $uid2, $split2, $sync->{ acc2 }, $sync ) ; + + +$sync->{ debug } and $sync->{imap1} and myprint( 'Host1 Buffer I/O: ', $sync->{imap1}->Buffer(), "\n" ) ; +$sync->{ debug } and $sync->{imap2} and myprint( 'Host2 Buffer I/O: ', $sync->{imap2}->Buffer(), "\n" ) ; + + +if ( ! $sync->{imap1} || ! $sync->{imap2} ) +{ + exit_most_errors( $sync ) ; +} + + +myprint( "Host1: state Authenticated\n" ) ; +myprint( "Host2: state Authenticated\n" ) ; + +myprint( 'Host1 capability once authenticated: ', join(q{ }, @{ $sync->{imap1}->capability() || [] }), "\n" ) ; + +#myprint( Data::Dumper->Dump( [ $sync->{imap1} ] ) ) ; +#myprint( "imap4rev1: " . $sync->{imap1}->imap4rev1() . "\n" ) ; + +myprint( 'Host2 capability once authenticated: ', join(q{ }, @{ $sync->{imap2}->capability() || [] }), "\n" ) ; + +imap_id_stuff( $sync ) ; + +#quota( $sync, $sync->{imap1}, 'h1' ) ; # quota on host1 is useless and pollute host2 output. +quota( $sync, $sync->{imap2}, 'h2' ) ; + +maxsize_setting( $sync ) ; + +acc_compress_imap( $acc1 ) ; +acc_compress_imap( $acc2 ) ; + +if ( $sync->{ justlogin } ) { + $sync->{imap1}->logout( ) ; + $sync->{imap2}->logout( ) ; + exit_clean( $sync, $EX_OK, "Exiting because of --justlogin\n" ) ; +} + + +# +# Folder stuff +# + +$h1_folders_wanted_nb = 0 ; # counter of folders to be done. +$h1_folders_wanted_ct = 0 ; # counter of folders done. + +# All folders on host1 and host2 + +@h1_folders_all = sort $sync->{imap1}->folders( ) ; +@h2_folders_all = sort $sync->{imap2}->folders( ) ; + +myprint( 'Host1: found ', scalar @h1_folders_all , " folders.\n" ) ; +myprint( 'Host2: found ', scalar @h2_folders_all , " folders.\n" ) ; + +foreach my $f ( @h1_folders_all ) +{ + $h1_folders_all{ $f } = 1 +} + +foreach my $f ( @h2_folders_all ) +{ + $h2_folders_all{ $f } = 1 ; + $sync->{h2_folders_all_UPPER}{ uc $f } = 1 ; +} + +$sync->{h1_folders_all} = \%h1_folders_all ; +$sync->{h2_folders_all} = \%h2_folders_all ; + + +private_folders_separators_and_prefixes( ) ; + + +# Make a hash of subscribed folders in both servers. + +for ( $sync->{imap1}->subscribed( ) ) { $h1_subscribed_folder{ $_ } = 1 } ; +for ( $sync->{imap2}->subscribed( ) ) { $h2_subscribed_folder{ $_ } = 1 } ; + + +if ( defined $sync->{ subfolder1 } ) { + subfolder1( $sync ) ; +} + + + + +if ( defined $sync->{ subfolder2 } ) { + subfolder2( $sync ) ; +} + +if ( $fixInboxINBOX and ( my $reg = fix_Inbox_INBOX_mapping( \%h1_folders_all, \%h2_folders_all ) ) ) { + push @{ $sync->{ regextrans2 } }, $reg ; +} + + + +if ( ( $sync->{ folder } and scalar @{ $sync->{ folder } } ) + or $subscribed + or scalar @folderrec ) +{ + # folders given by option --folder + if ( $sync->{ folder } and scalar @{ $sync->{ folder } } ) { + add_to_requested_folders( @{ $sync->{ folder } } ) ; + } + + # option --subscribed + if ( $subscribed ) { + add_to_requested_folders( keys %h1_subscribed_folder ) ; + } + + # option --folderrec + if ( scalar @folderrec ) { + foreach my $folderrec ( @folderrec ) { + add_to_requested_folders( $sync->{imap1}->folders( $folderrec ) ) ; + } + } +} +else +{ + # no include, no folder/subscribed/folderrec options => all folders + if ( not scalar @include ) { + myprint( "Including all folders found by default. Use --subscribed or --folder or --folderrec or --include to select specific folders. Use --exclude to unselect specific folders.\n" ) ; + add_to_requested_folders( @h1_folders_all ) ; + } +} + + +# consider (optional) includes and excludes +if ( scalar @include ) { + foreach my $include ( @include ) { + # No, do not add /x after the regex, never. + # Users would kill you! + my @included_folders = grep { /$include/ } @h1_folders_all ; + add_to_requested_folders( @included_folders ) ; + myprint( "Including folders matching pattern $include\n" . jux_utf8_list( @included_folders ) . "\n" ) ; + } +} + +if ( scalar @exclude ) { + foreach my $exclude ( @exclude ) { + my @requested_folder = sort keys %requested_folder ; + # No, do not add /x after the regex, never. + # Users would kill you! + my @excluded_folders = grep { /$exclude/ } @requested_folder ; + remove_from_requested_folders( @excluded_folders ) ; + myprint( "Excluding folders matching pattern $exclude\n" . jux_utf8_list( @excluded_folders ) . "\n" ) ; + } +} + + +# sort before is not very powerful +# it adds --folderfirst and --folderlast even if they don't exist on host1 +#@h1_folders_wanted = sort_requested_folders( ) ; +$sync->{h1_folders_wanted} = [ sort_requested_folders( ) ] ; + +# Remove no selectable folders + + +if ( $sync->{ checkfoldersexist } ) { + my @h1_folders_wanted_exist ; + myprint( "Host1: Checking wanted folders exist. Use --nocheckfoldersexist to avoid this check (shared of public namespace targeted).\n" ) ; + foreach my $folder ( @{ $sync->{h1_folders_wanted} } ) { + ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "Checking $folder exists on host1\n" ) ; + if ( ! exists $h1_folders_all{ $folder } ) { + myprint( "Host1: warning! ignoring folder $folder because it is not in host1 whole folders list.\n" ) ; + next ; + }else{ + push @h1_folders_wanted_exist, $folder ; + } + } + @{ $sync->{h1_folders_wanted} } = @h1_folders_wanted_exist ; +}else{ + myprint( "Host1: Not checking that wanted folders exist. Remove --nocheckfoldersexist to get this check.\n" ) ; +} + +setcheckselectable( $sync ) ; + +checkselectable( $sync ) ; + + + +# Local bugfix. OpenFind folders named like "kk \*123" are in fact "kk *123" (no \) +#foreach my $folder ( @{ $sync->{ h1_folders_wanted } } ) +#{ +# $folder =~ s{ \\\*}{ *}g ; +#} + + +# this hack is because LWP post does not pass well a hash in the $form parameter +# but it does pass well an array +#%{ $sync->{f1f2h} } = split_around_equal( @{ $sync->{f1f2} } ) ; +make_f1f2_array_to_a_hash( $sync ) ; + +automap( $sync ) ; + + +foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) { + my $h2_fold ; + $h2_fold = imap2_folder_name( $sync, $h1_fold ) ; + $h2_folders_from_1_wanted{ $h2_fold }++ ; + if ( 1 < $h2_folders_from_1_wanted{ $h2_fold } ) { + $h2_folders_from_1_several{ $h2_fold }++ ; + } +} + +@h2_folders_from_1_wanted = sort keys %h2_folders_from_1_wanted; + + +foreach my $h1_fold ( @h1_folders_all ) { + my $h2_fold ; + $h2_fold = imap2_folder_name( $sync, $h1_fold ) ; + $h2_folders_from_1_all{ $h2_fold }++ ; + # Follows a fix to avoid deleting folder $sync->{ subfolder2 } + # because it usually does not exist on host1. + if ( $sync->{ subfolder2 } ) + { + $h2_folders_from_1_all{ $sync->{ h2_prefix } . $sync->{ subfolder2 } }++ ; + $h2_folders_from_1_all{ $sync->{ subfolder2 } }++ ; + } +} + + + +myprint( << 'END_LISTING' ) ; + +++++ Listing folders +All foldernames are presented between brackets like [X] where X is the foldername. +When a foldername contains non-ASCII characters it is presented in the form +[X] = [Y] where +X is the imap foldername you have to use in command line options and +Y is the utf8 output just printed for convenience, to recognize it. + +END_LISTING + +myprint( + "Host1: folders list (first the raw imap format then the [X] = [Y]):\n", + $sync->{imap1}->list( ), + "\n", + jux_utf8_list( @h1_folders_all ), + "\n", + "Host2: folders list (first the raw imap format then the [X] = [Y]):\n", + $sync->{imap2}->list( ), + "\n", + jux_utf8_list( @h2_folders_all ), + "\n", + q{} +) ; + +if ( $subscribed ) { + myprint( + 'Host1 subscribed folders list: ', + jux_utf8_list( sort keys %h1_subscribed_folder ), "\n", + ) ; +} + + + +@h2_folders_not_in_1 = list_folders_in_2_not_in_1( ) ; + +if ( @h2_folders_not_in_1 ) { + myprint( "Folders in host2 not in host1:\n", + jux_utf8_list( @h2_folders_not_in_1 ), "\n" ) ; +} + + +if ( keys %{ $sync->{f1f2auto} } ) { + myprint( "Folders mapping from --automap feature (use --f1f2 to override any mapping):\n" ) ; + foreach my $h1_fold ( keys %{ $sync->{f1f2auto} } ) { + my $h2_fold = $sync->{f1f2auto}{$h1_fold} ; + myprintf( "%-40s -> %-40s\n", + jux_utf8( $h1_fold ), jux_utf8( $h2_fold ) ) ; + } + myprint( "\n" ) ; +} + +if ( keys %{ $sync->{f1f2h} } ) { + myprint( "Folders mapping from --f1f2 options, it overrides --automap:\n" ) ; + foreach my $h1_fold ( keys %{ $sync->{f1f2h} } ) { + my $h2_fold = $sync->{f1f2h}{$h1_fold} ; + my $warn = q{} ; + if ( not exists $h1_folders_all{ $h1_fold } ) { + $warn = "BUT $h1_fold does NOT exist on host1!" ; + } + myprintf( "%-40s -> %-40s %s\n", + jux_utf8( $h1_fold ), jux_utf8( $h2_fold ), $warn ) ; + } + myprint( "\n" ) ; +} + +exit_clean( $sync, $EX_OK, "Exiting because of --justfolderlists\n" ) if ( $sync->{ justfolderlists } ) ; +exit_clean( $sync, $EX_OK, "Exiting because of --justautomap\n" ) if ( $sync->{ justautomap } ) ; + +debugsleep( $sync ) ; + +if ( $sync->{ skipemptyfolders } ) +{ + myprint( "Host1: will not syncing empty folders on host1. Use --noskipemptyfolders to create them anyway on host2\n") ; +} + +if ( $sync->{ checknoabletosearch } ) +{ + myprint( "Checking SEARCH ALL works on both accounts. To avoid that check, use --nochecknoabletosearch\n" ) ; + my $check1 = checknoabletosearch( $sync, $sync->{ imap1 }, 'INBOX', 'Host1' ) ; + my $check2 = checknoabletosearch( $sync, $sync->{ imap2 }, 'INBOX', 'Host2' ) ; + if ( $check1 or $check2 ) + { + myprint( "At least one account can not SEARCH ALL. So acting like --noabletosearch\n" ) ; + $sync->{abletosearch} = 0 ; + $sync->{abletosearch1} = 0 ; + $sync->{abletosearch2} = 0 ; + } + else + { + myprint( "Good! SEARCH ALL works on both accounts.\n" ) ; + } +} + + + +if ( $sync->{ foldersizes } ) { + + foldersizes_at_the_beggining( $sync ) ; + #foldersizes_at_the_beggining_old( $sync ) ; +} + + + +if ( $sync->{ justfoldersizes } ) +{ + exit_clean( $sync, $EX_OK, "Exiting because of --justfoldersizes\n" ) ; +} + +$sync->{can_do_stats} = 1 ; + +if ( $sync->{ delete1emptyfolders } ) { + delete1emptyfolders( $sync ) ; +} + +delete_folders_in_2_not_in_1( ) if $delete2folders ; + +# folder loop +$h1_folders_wanted_nb = scalar @{ $sync->{h1_folders_wanted} } ; + +myprint( "++++ Looping on each one of $h1_folders_wanted_nb folders to sync\n" ) ; + +$sync->{begin_transfer_time} = time ; + +my %uid_candidate_for_deletion ; +my %uid_candidate_no_deletion ; + +$sync->{ h2_folders_of_md5 } = { } ; + + +FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) +{ + $sync->{ h1_current_folder } = $h1_fold ; + eta_print( $sync ) ; + abortifneeded( $sync ) ; + if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } + + my $h2_fold = imap2_folder_name( $sync, $h1_fold ) ; + $sync->{ h2_current_folder } = $h2_fold ; + + $h1_folders_wanted_ct++ ; + myprintf( "Folder %7s %-35s -> %-35s\n", "$h1_folders_wanted_ct/$h1_folders_wanted_nb", + jux_utf8( $h1_fold ), jux_utf8( $h2_fold ) ) ; + myprint( debugmemory( $sync, " at folder loop" ) ) ; + + # host1 can not be fetched read only, select is needed because of expunge. + select_folder( $sync, $sync->{imap1}, $h1_fold, 'Host1' ) or next FOLDER ; + + debugsleep( $sync ) ; + + my $h1_msgs_all_hash_ref ; + my @h1_msgs ; + my $h1_msgs_nb ; + my $h1_msgs_nb_from_select ; + + $h1_msgs_nb_from_select = count_from_select( $sync->{imap1}->History ) ; + myprint( "Host1: folder [$h1_fold] has $h1_msgs_nb_from_select messages in total (mentioned by SELECT)\n" ) ; + + if ( $sync->{ skipemptyfolders } and 0 == $h1_msgs_nb_from_select ) { + myprint( "Host1: skipping empty host1 folder [$h1_fold]\n" ) ; + next FOLDER ; + } + + # Code added from https://github.com/imapsync/imapsync/issues/95 + # Thanks jh1995 + # Goal: do not create folder if --search or --max/minage return 0 message. + # even if there are messages by SELECT (no not real empty, empty for the user point of vue). + if ( $sync->{ skipemptyfolders } or $sync->{ dry } ) + { + $h1_msgs_all_hash_ref = { } ; + @h1_msgs = select_msgs( $sync->{imap1}, $h1_msgs_all_hash_ref, $sync->{ search1 }, $sync->{abletosearch1}, $h1_fold ) ; + + $h1_msgs_nb = scalar( @h1_msgs ) ; + if ( 0 == $h1_msgs_nb and $sync->{ skipemptyfolders } ) { + myprint( "Host1: skipping empty host1 folder [$h1_fold] (0 message found by SEARCH)\n" ) ; + next FOLDER ; + } + } + + if ( ! exists $h2_folders_all{ $h2_fold } ) { + # In --dry mode I could count the messages to be transfered instead of 0 + # Messages transferred : 0 (could be 0 without dry mode) + if ( ! create_folder( $sync, $sync->{imap2}, $h2_fold, $h1_fold ) ) + { + if ( $sync->{ dry } ) + { + $nb_msg_skipped_dry_mode += $h1_msgs_nb ; + } + next FOLDER ; + } + } + + acls_sync( $sync, $h1_fold, $h2_fold ) ; + + # Sometimes the folder on host2 is listed (it exists) but is + # not selectable but becomes selectable by a create (Gmail) + select_folder( $sync, $sync->{imap2}, $h2_fold, 'Host2' ) + or ( create_folder( $sync, $sync->{imap2}, $h2_fold, $h1_fold ) + and select_folder( $sync, $sync->{imap2}, $h2_fold, 'Host2' ) ) + or next FOLDER ; + my @select_results = $sync->{imap2}->Results( ) ; + + my $h2_fold_nb_messages = count_from_select( @select_results ) ; + myprint( "Host2: folder [$h2_fold] has $h2_fold_nb_messages messages in total (mentioned by SELECT)\n" ) ; + + $sync->{ permanentflags2 } = permanentflags( $sync, @select_results ) ; + myprint( "Host2: folder [$h2_fold] permanentflags: $sync->{ permanentflags2 }\n" ) ; + + if ( $sync->{ expunge1 } ) + { + myprint( "Host1: Expunging $h1_fold $sync->{dry_message}\n" ) ; + if ( ! $sync->{dry} ) + { + $sync->{imap1}->expunge( ) ; + } + } + + if ( ( ( $subscribe and exists $h1_subscribed_folder{ $h1_fold } ) or $subscribeall ) + and not exists $h2_subscribed_folder{ $h2_fold } ) + { + myprint( "Host2: Subscribing to folder $h2_fold\n" ) ; + if ( ! $sync->{dry} ) { $sync->{imap2}->subscribe( $h2_fold ) } ; + } + + next FOLDER if ( $sync->{ justfolders } ) ; + + if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } + + + if ( ! defined $h1_msgs_nb ) + { + $h1_msgs_all_hash_ref = { } ; + @h1_msgs = select_msgs( $sync->{imap1}, $h1_msgs_all_hash_ref, $sync->{ search1 }, $sync->{abletosearch1}, $h1_fold ); + $h1_msgs_nb = scalar @h1_msgs ; + }else{ + # select_msgs already done. + } + + if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } + + myprint( "Host1: folder [$h1_fold] considering $h1_msgs_nb messages\n" ) ; + ( $sync->{ debug } or $sync->{ debuglist } ) and myprint( "Host1: folder [$h1_fold] considering $h1_msgs_nb messages, LIST gives: @h1_msgs\n" ) ; + $sync->{ debug } and myprint( "Host1: selecting messages of folder [$h1_fold] took ", timenext( $sync ), " s\n" ) ; + + my $h2_msgs_all_hash_ref = { } ; + my @h2_msgs = select_msgs( $sync->{imap2}, $h2_msgs_all_hash_ref, $sync->{ search2 }, $sync->{abletosearch2}, $h2_fold ) ; + + if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } + + my $h2_msgs_nb = scalar @h2_msgs ; + + myprint( "Host2: folder [$h2_fold] considering $h2_msgs_nb messages\n" ) ; + ( $sync->{ debug } or $sync->{ debuglist } ) and myprint( "Host2: folder [$h2_fold] considering $h2_msgs_nb messages, LIST gives: @h2_msgs\n" ) ; + $sync->{ debug } and myprint( "Host2: selecting messages of folder [$h2_fold] took ", timenext( $sync ), " s\n" ) ; + + my $cache_base = "$sync->{ tmpdir }/imapsync_cache/" ; + my $cache_dir = cache_folder( $cache_base, + "$sync->{host1}/$sync->{user1}/$sync->{host2}/$sync->{user2}", $h1_fold, $h2_fold ) ; + my ( $cache_1_2_ref, $cache_2_1_ref ) = ( {}, {} ) ; + + my $h1_uidvalidity = $sync->{imap1}->uidvalidity( ) || q{} ; + my $h2_uidvalidity = $sync->{imap2}->uidvalidity( ) || q{} ; + + if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } + + if ( $sync->{ usecache } ) { + myprint( "Local cache directory: $cache_dir ( " . length( $cache_dir ) . " characters long )\n" ) ; + mkpath( "$cache_dir" ) ; + ( $cache_1_2_ref, $cache_2_1_ref ) + = get_cache( $cache_dir, \@h1_msgs, \@h2_msgs, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ; + myprint( 'CACHE h1 h2: ', scalar keys %{ $cache_1_2_ref } , " files\n" ) ; + $sync->{ debug } and myprint( '[', + map ( { "$_->$cache_1_2_ref->{$_} " } keys %{ $cache_1_2_ref } ), " ]\n" ) ; + } + + my %h1_hash = ( ) ; + my %h2_hash = ( ) ; + + my ( %h1_msgs, %h2_msgs ) ; + @h1_msgs{ @h1_msgs } = ( ) ; + @h2_msgs{ @h2_msgs } = ( ) ; + + my @h1_msgs_in_cache = sort { $a <=> $b } keys %{ $cache_1_2_ref } ; + my @h2_msgs_in_cache = sort { $a <=> $b } keys %{ $cache_2_1_ref } ; + + my ( %h1_msgs_not_in_cache, %h2_msgs_not_in_cache ) ; + %h1_msgs_not_in_cache = %h1_msgs ; + %h2_msgs_not_in_cache = %h2_msgs ; + delete @h1_msgs_not_in_cache{ @h1_msgs_in_cache } ; + delete @h2_msgs_not_in_cache{ @h2_msgs_in_cache } ; + + my @h1_msgs_not_in_cache = sort { $a <=> $b } keys %h1_msgs_not_in_cache ; + #myprint( "h1_msgs_not_in_cache: [@h1_msgs_not_in_cache]\n" ) ; + my @h2_msgs_not_in_cache = sort { $a <=> $b } keys %h2_msgs_not_in_cache ; + + my @h2_msgs_delete2_not_in_cache = () ; + %h1_msgs_copy_by_uid = ( ) ; + + if ( $useuid ) { + # use uid so we have to avoid getting header + @h1_msgs_copy_by_uid{ @h1_msgs_not_in_cache } = ( ) ; + @h2_msgs_delete2_not_in_cache = @h2_msgs_not_in_cache if $sync->{ usecache } ; + @h1_msgs_not_in_cache = ( ) ; + @h2_msgs_not_in_cache = ( ) ; + + #myprint( "delete2: @h2_msgs_delete2_not_in_cache\n" ) ; + } + + if ( $sync->{ debug } or ( 5000 <= scalar( @h1_msgs_not_in_cache ) ) ) + { + myprint( "Host1: parsing headers of folder [$h1_fold]. It can take time for huge folders. Be patient.\n" ) ; + } + + my ( $h1_heads_ref, $h1_fir_ref ) = ( {}, {} ) ; + $h1_heads_ref = $sync->{ imap1 }->parse_headers( [ @h1_msgs_not_in_cache ], @useheader ) if ( @h1_msgs_not_in_cache ) ; + $sync->{ debug } and myprint( "Host1: parsing headers of folder [$h1_fold] took ", timenext( $sync ), " s\n" ) ; + + @{ $h1_fir_ref }{ @h1_msgs } = ( undef ) ; + + $sync->{ debug } and myprint( "Host1: getting flags idate and sizes of folder [$h1_fold]\n" ) ; + + my @h1_common_fetch_param = ( 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE' ) ; + if ( $sync->{ synclabels } or $sync->{ resynclabels } ) { push @h1_common_fetch_param, 'X-GM-LABELS' ; } + + if ( $sync->{ abletosearch1 } ) + { + $h1_fir_ref = $sync->{ imap1 }->fetch_hash( \@h1_msgs, @h1_common_fetch_param, $h1_fir_ref ) + if ( @h1_msgs ) ; + } + else + { + my $fetch_hash_uids = $fetch_hash_set || "1:*" ; + $h1_fir_ref = $sync->{ imap1 }->fetch_hash( $fetch_hash_uids, @h1_common_fetch_param, $h1_fir_ref ) + if ( @h1_msgs ) ; + } + + $sync->{ debug } and myprint( "Host1: getting flags idate and sizes of folder [$h1_fold] took ", timenext( $sync ), " s\n" ) ; + if ( ! $h1_fir_ref ) + { + my $error = join( q{}, "Host1: folder $h1_fold : Could not fetch_hash ", + scalar @h1_msgs, ' msgs: ', $sync->{imap1}->LastError || q{}, "\n" ) ; + errors_incr( $sync, $error ) ; + next FOLDER ; + } + + my @h1_msgs_duplicate; + foreach my $m ( @h1_msgs_not_in_cache ) + { + my $rc = parse_header_msg( $sync, $sync->{imap1}, $m, $h1_fold, $h1_heads_ref, $h1_fir_ref, 'Host1', \%h1_hash ) ; + if ( ! defined $rc ) + { + my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0; + myprint( "Host1: $h1_fold/$m size $h1_size ignored (no wanted headers so we ignore this message. To solve this: use --addheader)\n" ) ; + $sync->{ total_bytes_skipped } += $h1_size ; + $sync->{ nb_msg_skipped } += 1 ; + $sync->{ h1_nb_msg_noheader } +=1 ; + $sync->{ h1_nb_msg_processed } +=1 ; + } elsif( 0 == $rc ) + { + # duplicate + push @h1_msgs_duplicate, $m; + # duplicate, same id same size? + my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0; + + $sync->{ acc1 }->{ nb_msg_duplicate } += 1; + if ( ! $sync->{ syncduplicates } ) { + $sync->{ nb_msg_skipped } += 1 ; + $sync->{ h1_nb_msg_processed } +=1 ; + } + } + } + + + my $h1_msgs_duplicate_nb = scalar @h1_msgs_duplicate ; + + myprint( "Host1: folder [$h1_fold] selected $h1_msgs_nb messages, duplicates $h1_msgs_duplicate_nb\n" ) ; + + $sync->{ debug } and myprint( 'Host1: whole time parsing headers took ', timenext( $sync ), " s\n" ) ; + + # Getting headers and metada can be so long that host2 might be disconnected here + if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } + + + if ( $sync->{ debug } or ( 5000 <= scalar( @h2_msgs_not_in_cache ) ) ) + { + myprint( "Host2: parsing headers of folder [$h2_fold]. It can take time for huge folders. Be patient.\n" ) ; + } + + my ( $h2_heads_ref, $h2_fir_ref ) = ( {}, {} ); + $h2_heads_ref = $sync->{ imap2 }->parse_headers( [ @h2_msgs_not_in_cache ], @useheader ) if ( @h2_msgs_not_in_cache ); + $sync->{ debug } and myprint( "Host2: parsing headers of folder [$h2_fold] took ", timenext( $sync ), " s\n" ) ; + + $sync->{ debug } and myprint( "Host2: getting flags idate and sizes of folder [$h2_fold]\n" ) ; + @{ $h2_fir_ref }{ @h2_msgs } = ( ); # fetch_hash can select by uid with last arg as ref + + + my @h2_common_fetch_param = ( 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE' ) ; + if ( $sync->{ synclabels } or $sync->{ resynclabels } ) { push @h2_common_fetch_param, 'X-GM-LABELS' ; } + + if ( $sync->{ abletosearch2 } and scalar( @h2_msgs ) ) { + $h2_fir_ref = $sync->{ imap2 }->fetch_hash( \@h2_msgs, @h2_common_fetch_param, $h2_fir_ref ) ; + }else{ + my $fetch_hash_uids = $fetch_hash_set || "1:*" ; + $h2_fir_ref = $sync->{ imap2 }->fetch_hash( $fetch_hash_uids, @h2_common_fetch_param, $h2_fir_ref ) + if ( @h2_msgs ) ; + } + + $sync->{ debug } and myprint( "Host2: getting flags idate and sizes of folder [$h2_fold] took ", timenext( $sync ), " s\n" ) ; + + my @h2_msgs_duplicate; + foreach my $m (@h2_msgs_not_in_cache) { + my $rc = parse_header_msg( $sync, $sync->{imap2}, $m, $h2_fold, $h2_heads_ref, $h2_fir_ref, 'Host2', \%h2_hash ) ; + my $h2_size = $h2_fir_ref->{$m}->{'RFC822.SIZE'} || 0 ; + if (! defined $rc ) { + myprint( "Host2: $h2_fold/$m size $h2_size ignored (no wanted headers so we ignore this message)\n" ) ; + $h2_nb_msg_noheader += 1 ; + } elsif( 0 == $rc ) { + # duplicate + $sync->{ acc2 }->{ nb_msg_duplicate } += 1 ; + push @h2_msgs_duplicate, $m ; + } + } + + # %h2_folders_of_md5 + foreach my $md5 ( keys %h2_hash ) { + $sync->{ h2_folders_of_md5 }->{ $md5 }->{ $h2_fold } ++ ; + } + # %h1_folders_of_md5 + foreach my $md5 ( keys %h1_hash ) { + $sync->{ h1_folders_of_md5 }->{ $md5 }->{ $h2_fold } ++ ; + } + + + my $h2_msgs_duplicate_nb = scalar @h2_msgs_duplicate ; + + myprint( "Host2: folder [$h2_fold] selected $h2_msgs_nb messages, duplicates $h2_msgs_duplicate_nb\n" ) ; + + $sync->{ debug } and myprint( 'Host2 whole time parsing headers took ', timenext( $sync ), " s\n" ) ; + + $sync->{ debug } and myprint( "++++ Verifying [$h1_fold] -> [$h2_fold]\n" ) ; + # messages in host1 that are not in host2 + + my @h1_hash_keys_sorted_by_uid + = sort {$h1_hash{$a}{'m'} <=> $h1_hash{$b}{'m'}} keys %h1_hash; + + #myprint( map { $h1_hash{$_}{'m'} . q{ }} @h1_hash_keys_sorted_by_uid ) ; + + my @h2_hash_keys_sorted_by_uid + = sort {$h2_hash{$a}{'m'} <=> $h2_hash{$b}{'m'}} keys %h2_hash; + + # Deletions on account2. + + if( $sync->{ delete2duplicates } and not exists $h2_folders_from_1_several{ $h2_fold } ) { + my @h2_expunge ; + + foreach my $h2_msg ( @h2_msgs_duplicate ) { + myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted [duplicate] on host2 $sync->{dry_message}\n" ) ; + push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 } ; + if ( ! $sync->{ dry } ) { + $sync->{ imap2 }->delete_message( $h2_msg ) ; + $sync->{ acc2 }->{ nb_msg_deleted } += 1 ; + } + } + my $cnt = scalar @h2_expunge ; + if( @h2_expunge and not $sync->{ expunge2 } ) { + myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ; + $sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ; + } + if ( $sync->{ expunge2 } ){ + myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ; + $sync->{imap2}->expunge( ) if ! $sync->{dry} ; + } + } + + if( $sync->{ delete2 } and not exists $h2_folders_from_1_several{ $h2_fold } ) { + # No host1 folders f1a f1b ... going all to same f2 (via --regextrans2) + my @h2_expunge; + foreach my $m_id (@h2_hash_keys_sorted_by_uid) { + #myprint( "$m_id " ) ; + if ( ! exists $h1_hash{$m_id} ) { + my $h2_msg = $h2_hash{$m_id}{'m'}; + my $h2_flags = $h2_hash{$m_id}{'F'} || q{}; + my $isdel = $h2_flags =~ /\B\\Deleted\b/x ? 1 : 0; + myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted on host2 [$m_id] $sync->{dry_message}\n" ) + if ! $isdel; + push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 }; + if ( ! ( $sync->{ dry } or $isdel ) ) { + $sync->{ imap2 }->delete_message( $h2_msg ); + $sync->{ acc2 }->{ nb_msg_deleted } += 1; + } + } + } + foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) { + myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted [not in cache] on host2 $sync->{dry_message}\n" ) ; + push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 }; + if ( ! $sync->{dry} ) { + $sync->{ imap2 }->delete_message( $h2_msg ); + $sync->{ acc2 }->{ nb_msg_deleted } += 1; + } + } + my $cnt = scalar @h2_expunge ; + + if( @h2_expunge and not $sync->{ expunge2 } ) { + myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ; + $sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ; + } + if ( $sync->{ expunge2 } ) { + myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ; + $sync->{imap2}->expunge( ) if ! $sync->{dry} ; + } + } + + if( $sync->{ delete2 } and exists $h2_folders_from_1_several{ $h2_fold } ) { + myprint( "Host2: folder $h2_fold $h2_folders_from_1_several{ $h2_fold } folders left to sync there\n" ) ; + my @h2_expunge; + foreach my $m_id ( @h2_hash_keys_sorted_by_uid ) { + my $h2_msg = $h2_hash{ $m_id }{ 'm' } ; + if ( ! exists $h1_hash{ $m_id } ) { + my $h2_flags = $h2_hash{ $m_id }{ 'F' } || q{} ; + my $isdel = $h2_flags =~ /\B\\Deleted\b/x ? 1 : 0 ; + if ( ! $isdel ) { + $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion [$m_id]\n" ) ; + $uid_candidate_for_deletion{ $h2_fold }{ $h2_msg }++ ; + } + }else{ + $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [$m_id]\n" ) ; + $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; + } + } + foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) { + myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion [not in cache]\n" ) ; + $uid_candidate_for_deletion{ $h2_fold }{ $h2_msg }++ ; + } + + foreach my $h2_msg ( @h2_msgs_in_cache ) { + myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [in cache]\n" ) ; + $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; + } + + + if ( 0 == $h2_folders_from_1_several{ $h2_fold } ) { + # last host1 folder going to $h2_fold + myprint( "Last host1 folder going to $h2_fold\n" ) ; + foreach my $h2_msg ( keys %{ $uid_candidate_for_deletion{ $h2_fold } } ) { + $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion\n" ) ; + if ( exists $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg } ) { + $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg canceled deletion\n" ) ; + }else{ + myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted $sync->{dry_message}\n" ) ; + push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 } ; + if ( ! $sync->{ dry} ) { + $sync->{ imap2 }->delete_message( $h2_msg ) ; + $sync->{ acc2 }->{ nb_msg_deleted } += 1 ; + } + } + } + } + + my $cnt = scalar @h2_expunge ; + if( @h2_expunge and not $sync->{ expunge2 } ) { + myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ; + $sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ; + } + if ( $sync->{ expunge2 } ) { + myprint( "Host2: Expunging host2 folder $h2_fold $sync->{dry_message}\n" ) ; + $sync->{imap2}->expunge( ) if ! $sync->{dry} ; + } + + $h2_folders_from_1_several{ $h2_fold }-- ; + } + + my $h2_uidnext = $sync->{imap2}->uidnext( $h2_fold ) ; + $sync->{ debug } and myprint( "Host2: uidnext is $h2_uidnext\n" ) ; + $h2_uidguess = $h2_uidnext ; + + # Getting host2 headers, metada and delete2 stuff can be so long that host1 might be disconnected here + if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } + + my @h1_msgs_to_delete ; + MESS: foreach my $m_id (@h1_hash_keys_sorted_by_uid) { + abortifneeded( $sync ) ; + if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } + + #myprint( "h1_nb_msg_processed: $sync->{ h1_nb_msg_processed }\n" ) ; + my $h1_size = $h1_hash{$m_id}{'s'}; + my $h1_msg = $h1_hash{$m_id}{'m'}; + my $h1_idate = $h1_hash{$m_id}{'D'}; + + #my $labels = labels( $sync->{imap1}, $h1_msg ) ; + #print "LABELS: $labels\n" ; + + if ( ( not exists $h2_hash{ $m_id } ) + and ( not ( exists $sync->{ h2_folders_of_md5 }->{ $m_id } ) + or not $sync->{ skipcrossduplicates } ) ) + { + # copy + my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $cache_dir ) ; + if ( $h2_msg and $sync->{ delete1 } and not $sync->{ expungeaftereach } ) { + # not expunged + push @h1_msgs_to_delete, $h1_msg ; + } + + # A bug here with imapsync 1.920, fixed in 1.921 + # Added $h2_msg in the condition. Errors of APPEND were not counted as missing messages on host2! + if ( $h2_msg and not $sync->{ dry } ) + { + $sync->{ h2_folders_of_md5 }->{ $m_id }->{ $h2_fold } ++ ; + } + + # + if( $sync->{ delete2 } and ( exists $h2_folders_from_1_several{ $h2_fold } ) and $h2_msg ) { + myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ) ; + $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; + } + + if ( total_bytes_max_reached( $sync ) ) { + # Still a bug when using --delete1 --noexpungeaftereach + # same thing below on all total_bytes_max_reached! + last FOLDER ; + } + next MESS; + } + else + { + # already on host2 + if ( exists $h2_hash{ $m_id } ) + { + my $h2_msg = $h2_hash{$m_id}{'m'} ; + $sync->{ debug } and myprint( "Host1: found that msg $h1_fold/$h1_msg equals Host2 $h2_fold/$h2_msg\n" ) ; + if ( $sync->{ usecache } ) + { + $debugcache and myprint( "touch $cache_dir/${h1_msg}_$h2_msg\n" ) ; + touch( "$cache_dir/${h1_msg}_$h2_msg" ) + or croak( "Couldn't touch $cache_dir/${h1_msg}_$h2_msg" ) ; + } + } + elsif( exists $sync->{ h2_folders_of_md5 }->{ $m_id } ) + { + my @folders_dup = keys %{ $sync->{ h2_folders_of_md5 }->{ $m_id } } ; + ( $sync->{ debug } or $sync->{ debugcrossduplicates } ) and myprint( "Host1: found that msg $h1_fold/$h1_msg is also in Host2 folders @folders_dup\n" ) ; + $sync->{ h2_nb_msg_crossdup } +=1 ; + } + $sync->{ total_bytes_skipped } += $h1_size ; + $sync->{ nb_msg_skipped } += 1 ; + $sync->{ h1_nb_msg_processed } +=1 ; + } + + if ( exists $h2_hash{ $m_id } ) { + #$debug and myprint( "MESSAGE $m_id\n" ) ; + my $h2_msg = $h2_hash{$m_id}{'m'}; + if ( $sync->{resyncflags} ) { + sync_flags_fir( $sync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $h1_fir_ref, $h2_fir_ref ) ; + } + # Good + my $h2_size = $h2_hash{$m_id}{'s'}; + $sync->{ debug } and myprint( + "Host1: size msg $h1_fold/$h1_msg = $h1_size <> $h2_size = Host2 $h2_fold/$h2_msg\n" ) ; + + if ( $sync->{ resynclabels } ) + { + resynclabels( $sync, $h1_msg, $h2_msg, $h1_fir_ref, $h2_fir_ref, $h1_fold ) + } + } + + if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } + + if ( $sync->{ delete1 } ) { + push @h1_msgs_to_delete, $h1_msg ; + } + } + # END MESS: loop + + # @h1_msgs_in_cache are already synced too. + delete_message_on_host1( $sync, $h1_fold, $sync->{ expunge1 }, @h1_msgs_to_delete, @h1_msgs_in_cache ) ; + + if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } + + # MESS_IN_CACHE: + if ( ! $sync->{ delete1 } ) + { + foreach my $h1_msg ( @h1_msgs_in_cache ) + { + my $h2_msg = $cache_1_2_ref->{ $h1_msg } ; + $debugcache and myprint( "cache messages update flags $h1_msg->$h2_msg\n" ) ; + if ( $sync->{resyncflags} ) + { + sync_flags_fir( $sync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $h1_fir_ref, $h2_fir_ref ) ; + } + my $h1_size = $h1_fir_ref->{ $h1_msg }->{ 'RFC822.SIZE' } || 0 ; + $sync->{ total_bytes_skipped } += $h1_size; + $sync->{ nb_msg_skipped } += 1; + $sync->{ h1_nb_msg_processed } +=1 ; + } + } + + if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } + + @h1_msgs_to_delete = ( ) ; + #myprint( "Messages by uid: ", map { "$_ " } keys %h1_msgs_copy_by_uid, "\n" ) ; + # MESS_BY_UID: + foreach my $h1_msg ( sort { $a <=> $b } keys %h1_msgs_copy_by_uid ) + { + abortifneeded( $sync ) ; + $sync->{ debug } and myprint( "Copy by uid $h1_fold/$h1_msg\n" ) ; + if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } + + my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $cache_dir ) ; + if( $sync->{ delete2 } and exists $h2_folders_from_1_several{ $h2_fold } and $h2_msg ) { + myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ) ; + $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; + } + last FOLDER if total_bytes_max_reached( $sync ) ; + } + + if ( $sync->{ expunge1 } ){ + myprint( "Host1: Expunging folder $h1_fold $sync->{dry_message}\n" ) ; + if ( ! $sync->{dry} ) { $sync->{imap1}->expunge( ) } ; + } + if ( $sync->{ expunge2 } ){ + myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ; + if ( ! $sync->{dry} ) { $sync->{imap2}->expunge( ) } ; + } + $sync->{ debug } and myprint( 'Time: ', timenext( $sync ), " s\n" ) ; +} + +eta_print( $sync ) ; + +myprint( "++++ End looping on each folder\n" ) ; + +if ( $sync->{ delete1 } and $sync->{ delete1emptyfolders } ) { + delete1emptyfolders( $sync ) ; +} + +( $sync->{ debug } or $sync->{debugfolders} ) and myprint( 'Time: ', timenext( $sync ), " s\n" ) ; + + +if ( $sync->{ foldersizesatend } ) { + myprint( << 'END_SIZE' ) ; + +Folders sizes after the synchronization. +You can remove this foldersizes listing by using "--nofoldersizesatend" +END_SIZE + + foldersizesatend( $sync ) ; +} + + +do_and_print_stats( $sync ) ; + + +if ( $sync->{ nb_errors } ) +{ + myprint( errors_listing( $sync ) ) ; +} + + +if ( $sync->{ testslive } or $sync->{ testslive6 } ) +{ + tests_live_result( $sync->{ nb_errors } ) ; +} + +final_emails_reports( $sync ) ; + +#$sync->{imap1}->State( 0 ); # Unconnected +if ( ! lost_connection( $sync, $sync->{imap1}, "for host1 [$sync->{host1}]" ) ) { $sync->{imap1}->logout( ) ; } +if ( ! lost_connection( $sync, $sync->{imap2}, "for host2 [$sync->{host2}]" ) ) { $sync->{imap2}->logout( ) ; } + +if ( $sync->{ nb_errors } ) +{ + my $exit_value = exit_value( $sync, $sync->{ most_common_error } ) ; + exit_clean( $sync, $exit_value ) ; +} +else +{ + exit_clean( $sync, $EX_OK ) ; +} + +return ; +} + +# END of sub single_sync + + +# subroutines +sub myprint +{ + #print @ARG ; + print { $sync->{ tee } || \*STDOUT } @ARG ; + return ; +} + +sub myprintf +{ + printf { $sync->{ tee } || \*STDOUT } @ARG ; + return ; +} + +sub mysprintf +{ + my( $format, @list ) = @ARG ; + return sprintf $format, @list ; +} + +sub output_start +{ + my $mysync = shift @ARG ; + + if ( not $mysync ) { return ; } + + my @output = @ARG ; + $mysync->{ output } = join( q{}, @output ) . ( $mysync->{ output } || q{} ) ; + return $mysync->{ output } ; +} + + +sub tests_output_start +{ + note( 'Entering tests_output_start()' ) ; + + my $mysync = { } ; + + is( undef, output_start( ), 'output_start: no args => undef' ) ; + is( q{}, output_start( $mysync ), 'output_start: one arg => ""' ) ; + is( 'rrrr', output_start( $mysync, 'rrrr' ), 'output_start: rrrr => rrrr' ) ; + is( 'aaaarrrr', output_start( $mysync, 'aaaa' ), 'output_start: aaaa => aaaarrrr' ) ; + is( "\naaaarrrr", output_start( $mysync, "\n" ), 'output_start: \n => \naaaarrrr' ) ; + is( "ABC\naaaarrrr", output_start( $mysync, 'A', 'B', 'C' ), 'output_start: A B C => ABC\naaaarrrr' ) ; + + note( 'Leaving tests_output_start()' ) ; + return ; +} + +sub tests_output +{ + note( 'Entering tests_output()' ) ; + + my $mysync = { } ; + + is( undef, output( ), 'output: no args => undef' ) ; + is( q{}, output( $mysync ), 'output: one arg => ""' ) ; + is( 'rrrr', output( $mysync, 'rrrr' ), 'output: rrrr => rrrr' ) ; + is( 'rrrraaaa', output( $mysync, 'aaaa' ), 'output: aaaa => rrrraaaa' ) ; + is( "rrrraaaa\n", output( $mysync, "\n" ), 'output: \n => rrrraaaa\n' ) ; + is( "rrrraaaa\nABC", output( $mysync, 'A', 'B', 'C' ), 'output: A B C => rrrraaaaABC\n' ) ; + + note( 'Leaving tests_output()' ) ; + return ; +} + +sub output +{ + my $mysync = shift @ARG ; + + if ( not $mysync ) { return ; } + + my @output = @ARG ; + $mysync->{ output } .= join( q{}, @output ) ; + return $mysync->{ output } ; +} + + + +sub tests_output_reset_with +{ + note( 'Entering tests_output_reset_with()' ) ; + + my $mysync = { } ; + + is( undef, output_reset_with( ), 'output_reset_with: no args => undef' ) ; + is( q{}, output_reset_with( $mysync ), 'output_reset_with: one arg => ""' ) ; + is( 'rrrr', output_reset_with( $mysync, 'rrrr' ), 'output_reset_with: rrrr => rrrr' ) ; + is( 'aaaa', output_reset_with( $mysync, 'aaaa' ), 'output_reset_with: aaaa => aaaa' ) ; + is( "\n", output_reset_with( $mysync, "\n" ), 'output_reset_with: \n => \n' ) ; + + note( 'Leaving tests_output_reset_with()' ) ; + return ; +} + +sub output_reset_with +{ + my $mysync = shift @ARG ; + + if ( not $mysync ) { return ; } + + my @output = @ARG ; + $mysync->{ output } = join( q{}, @output ) ; + return $mysync->{ output } ; +} + + +sub tests_print_output_if_needed +{ + note( 'Entering tests_print_output_if_needed()' ) ; + + is( undef, print_output_if_needed( ), 'print_output_if_needed: no args => undef' ) ; + my $mysync = { } ; + is( q{}, print_output_if_needed( $mysync ), 'print_output_if_needed: undef => undef' ) ; + + output( $mysync, "Hello\n" ) ; + is( "Hello\n", print_output_if_needed( $mysync ), 'print_output_if_needed: Hello => Hello' ) ; + + $mysync->{ dockercontext } = 1 ; + is( "Hello\n", print_output_if_needed( $mysync ), 'print_output_if_needed: dockercontext + Hello => Hello' ) ; + + $mysync->{ version } = 1 ; + is( q{}, print_output_if_needed( $mysync ), 'print_output_if_needed: dockercontext + Hello + --version => ""' ) ; + + $mysync->{ dockercontext } = 0 ; + is( "Hello\n", print_output_if_needed( $mysync ), 'print_output_if_needed: Hello + --version => Hello' ) ; + + note( 'Leaving tests_print_output_if_needed()' ) ; + return ; +} + + +sub print_output_if_needed +{ + + my $mysync = shift @ARG ; + if ( ! defined $mysync ) { return ; } + my $output = output( $mysync ) ; + + if ( $mysync->{ version } && under_docker_context( $mysync ) ) + { + return q{} ; + } + else + { + myprint( $output ) ; + return $output ; + } + +} + + +sub stderr_to_stdout +{ + my $mysync = shift @ARG ; + if ( $mysync->{ tee} ) + { + *STDERR = *${ $mysync->{ tee } }{ IO } ; + } + else + { + *STDERR = *STDOUT ; + } + return ; +} + + + +sub determine_delete2duplicates +{ + my $mysync = shift @ARG ; + + if ( defined $mysync->{ delete2duplicates } ) + { + return $mysync->{ delete2duplicates } ; + } + + if ( $mysync->{ syncduplicates } ) + { + return 0 ; + } + + if ( $sync->{ delete2 } ) + { + return 1 ; + } + + return ; +} + +sub define_pidfile +{ + my $mysync = shift @ARG ; + + $mysync->{ pidfilelocking } = defined $mysync->{ pidfilelocking } ? $mysync->{ pidfilelocking } : 0 ; + + my $host1 = $mysync->{ host1 } || q{} ; + my $user1 = $mysync->{ user1 } || q{} ; + my $host2 = $mysync->{ host2 } || q{} ; + my $user2 = $mysync->{ user2 } || q{} ; + + my $account1_filtered = filter_forbidden_characters( slash_to_underscore( $host1 . '_' . $user1 ) ) || q{} ; + my $account2_filtered = filter_forbidden_characters( slash_to_underscore( $host2 . '_' . $user2 ) ) || q{} ; + + my $pidfile_basename ; + + if ( $ENV{ 'NET_SERVER_SOFTWARE' } and ( $ENV{ 'NET_SERVER_SOFTWARE' } =~ /Net::Server::HTTP/ ) ) + { + # under local webserver + $pidfile_basename = 'imapsync' . '_' . $account1_filtered . '_' . $account2_filtered . '.pid' ; + } + else + { + $pidfile_basename = 'imapsync.pid' ; + } + + $mysync->{ pidfile } = defined $mysync->{ pidfile } ? $mysync-> { pidfile } : $mysync->{ tmpdir } . "/$pidfile_basename" ; + $mysync->{ abortfile } = abortfile( $mysync, $PROCESS_ID ) ; + return ; +} + +sub abortfile +{ + my $mysync = shift @ARG ; + my $pid = shift @ARG ; + + my $abortfile ; + if ( $mysync->{ abort } ) + { + $abortfile = $mysync->{ pidfile } . "abort$pid" ; + } + else + { + $abortfile = $mysync->{ pidfile } . "abort$PROCESS_ID" ; + } + return $abortfile ; +} + +sub tests_kill_zero +{ + note( 'Entering tests_kill_zero()' ) ; + + + + SKIP: { + if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests tests_kill_zero avoided on Windows', 8 ) ; } + + + is( 1, kill( 'ZERO', $PROCESS_ID ), "kill ZERO : myself $PROCESS_ID => 1" ) ; + is( 2, kill( 'ZERO', $PROCESS_ID, $PROCESS_ID ), "kill ZERO : myself $PROCESS_ID $PROCESS_ID => 2" ) ; + + if ( (-e '/.dockerenv' ) or ( 0 == $EFFECTIVE_USER_ID) ) + { + is( 1, kill( 'ZERO', 1 ), "kill ZERO : pid 1 => 1 (docker context or root)" ) ; + is( 2, kill( 'ZERO', $PROCESS_ID, 1 ), "kill ZERO : myself + pid 1, $PROCESS_ID 1 => 2 (docker context or root)" ) ; + } + else + { + is( 0, kill( 'ZERO', 1 ), "kill ZERO : pid 1 => 0 (non root)" ) ; + is( 1, kill( 'ZERO', $PROCESS_ID, 1 ), "kill ZERO : myself + pid 1, $PROCESS_ID 1 => 1 (one is non root)" ) ; + + } + + + my $pid_1 = fork( ) ; + if ( $pid_1 ) + { + # parent + } + else + { + # child + sleep 3 ; + exit ; + } + + my $pid_2 ; + $pid_2 = fork( ) ; + if ( $pid_2 ) + { + # I am the parent + ok( defined( $pid_2 ), "kill_zero: initial fork ok. I am the parent $PROCESS_ID" ) ; + ok( $pid_2 , "kill_zero: initial fork ok, child pid is $pid_2" ) ; + is( 3, kill( 'ZERO', $PROCESS_ID, $pid_2, $pid_1 ), "kill ZERO : myself $PROCESS_ID and child $pid_2 and brother $pid_1 => 3" ) ; + + is( $pid_2, waitpid( $pid_2, 0 ), "kill_zero: child $pid_2 no more there => waitpid return $pid_2" ) ; + } + else + { + # I am the child + note( 'This one fails under Windows, kill ZERO returns 0 instead of 2' ) ; + is( 2, kill( 'ZERO', $PROCESS_ID, $pid_1 ), "kill ZERO : myself child $PROCESS_ID brother $pid_1 => 2" ) ; + myprint( "I am the child pid $PROCESS_ID, Exiting\n" ) ; + exit ; + } + wait( ) ; + + # End of SKIP block + } + + note( 'Leaving tests_kill_zero()' ) ; + return ; +} + + + + +sub tests_killpid_by_parent +{ + note( 'Entering tests_killpid_by_parent()' ) ; + + SKIP: { + if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests tests_killpid_by_parent avoided on Windows', 7 ) ; } + + is( undef, killpid( ), 'killpid: no args => undef' ) ; + note( "killpid: trying to kill myself pid $PROCESS_ID, hope I will not succeed" ) ; + is( undef, killpid( $PROCESS_ID ), 'killpid: myself => undef' ) ; + + local $SIG{'QUIT'} = sub { myprint "GOT SIG QUIT! I am PID $PROCESS_ID. Exiting\n" ; exit ; } ; + + my $pid ; + $pid = fork( ) ; + if ( $pid ) + { + # I am the parent + ok( defined( $pid ), "killpid: initial fork ok. I am the parent $PROCESS_ID" ) ; + ok( $pid , "killpid: initial fork ok, child pid is $pid" ) ; + + is( 2, kill( 'ZERO', $PROCESS_ID, $pid ), "kill ZERO : myself $PROCESS_ID and child $pid => 2" ) ; + is( 1, killpid( $pid ), "killpid: child $pid killed => 1" ) ; + is( -1, waitpid( $pid, 0 ), "killpid: child $pid no more there => waitpid return -1" ) ; + } + else + { + # I am the child + myprint( "I am the child pid $PROCESS_ID, sleeping 1 + 3 seconds then kill myself\n" ) ; + sleep 1 ; + myprint( "I am the child pid $PROCESS_ID, slept 1 second, should be killed by my parent now, PPID " . mygetppid( ) . "\n" ) ; + sleep 3 ; + # this test should not be run. If it happens => failure. + ok( 0 == 1, "killpid: child pid $PROCESS_ID not dead => failure" ) ; + myprint( "I am the child pid $PROCESS_ID, killing myself failure... Exiting\n" ) ; + exit ; + } + + # End of SKIP block + } + note( 'Leaving tests_killpid_by_parent()' ) ; + return ; +} + +sub tests_killpid_by_brother +{ + note( 'Entering tests_killpid_by_brother()' ) ; + + + SKIP: { + if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests tests_killpid_by_brother avoided on Windows', 2 ) ; } + + local $SIG{'QUIT'} = sub { myprint "GOT SIG QUIT! I am PID $PROCESS_ID. Exiting\n" ; exit ; } ; + + my $pid_parent = $PROCESS_ID ; + myprint( "I am the parent pid $pid_parent\n" ) ; + my $pid_1 = fork( ) ; + if ( $pid_1 ) + { + # parent + } + else + { + # child + #while ( 1 ) { } ; + sleep 2 ; + sleep 2 ; + # this test should not be run. If it happens => failure. + # Well under Windows this always fails, shit! + ok( 0 == 1 or ( 'MSWin32' eq $OSNAME ) , "killpid: child pid $PROCESS_ID killing by brother but not dead => failure" ) ; + myprint( "I am the child pid $PROCESS_ID, killing by brother failed... Exiting\n" ) ; + exit ; + } + + my $pid_2 ; + $pid_2 = fork( ) ; + if ( $pid_2 ) + { + # parent + } + else + { + # I am the child + myprint( "I am the child pid $PROCESS_ID, my brother has pid $pid_1\n" ) ; + is( 1, killpid( $pid_1 ), "killpid: brother $pid_1 killed => 1" ) ; + sleep 2 ; + exit ; + } + + #sleep 1 ; + is( $pid_1, waitpid( $pid_1, 0), "I am the parent $PROCESS_ID waitpid _1( $pid_1 )" ) ; + is( $pid_2, waitpid( $pid_2, 0 ), "I am the parent $PROCESS_ID waitpid _2( $pid_2 )" ) ; + + + # End of SKIP block + } + + note( 'Leaving tests_killpid_by_brother()' ) ; + return ; +} + + +sub killpid +{ + my $pidtokill = shift @ARG ; + + if ( ! $pidtokill ) { + myprint( "No process to kill.\n" ) ; + return ; + } + + if ( $PROCESS_ID == $pidtokill ) { + myprint( "I will not kill myself pid $PROCESS_ID via killpid. Sractch it!\n" ) ; + return ; + } + + + # First ask for suicide + if ( kill( 'ZERO', $pidtokill ) or ( 'MSWin32' eq $OSNAME ) ) { + myprint( "Sending signal QUIT to PID $pidtokill \n" ) ; + kill 'QUIT', $pidtokill ; + sleep 3 ; + waitpid( $pidtokill, WNOHANG) ; + }else{ + myprint( "Can not send signal kill ZERO to PID $pidtokill.\n" ) ; + return ; + } + + #while ( waitpid( $pidtokill, WNOHANG) > 0 ) { } ; + + # Then murder + if ( kill( 'ZERO', $pidtokill ) or ( 'MSWin32' eq $OSNAME ) ) { + myprint( "Sending signal KILL to PID $pidtokill \n" ) ; + kill 'KILL', $pidtokill ; + sleep 1 ; + waitpid( $pidtokill, WNOHANG) ; + }else{ + myprint( "Process PID $pidtokill ended.\n" ) ; + return 1; + } + # Well ... + if ( kill( 'ZERO', $pidtokill ) or ( 'xMSWin32' eq $OSNAME ) ) { + myprint( "Process PID $pidtokill seems still there. Can not do much.\n" ) ; + return ; + }else{ + myprint( "Process PID $pidtokill ended.\n" ) ; + return 1; + } + + return ; +} + +sub tests_abort +{ + note( 'Entering tests_abort()' ) ; + # Well, the abort behavior is tested by test.sh + is( undef, abort( ), 'abort: no args => undef' ) ; + note( 'Leaving tests_abort()' ) ; + return ; +} + + + + +sub abort +{ + my $mysync = shift @ARG ; + + myprint( "In abort\n" ) ; + if ( not $mysync ) { return ; } + + if ( ! -r $mysync->{pidfile} ) { + myprint( "In abort: Can not read pidfile $mysync->{pidfile}\n" ) ; + return ; + } + my $pidtokill = firstline( $mysync->{pidfile} ) ; + if ( ! $pidtokill ) { + myprint( "In abort: No process to abort in $mysync->{pidfile}\n" ) ; + return ; + } + + if ( ! match_a_pid_number( $pidtokill ) ) + { + myprint( "In abort: pid $pidtokill in $mysync->{pidfile} is not a pid number\n" ) ; + return ; + } + + + if ( $mysync->{abortbyfile} ) + { + abortbyfile( $mysync, $pidtokill ) ; + } + else + { + killpid( $pidtokill ) ; + } + return ; +} + +sub abortbyfile +{ + my $mysync = shift @ARG ; + my $pidtokill = shift @ARG ; + + my $abortfile = abortfile( $mysync, $pidtokill ) ; + myprint( "touching $abortfile\n" ) ; + touch( $abortfile ) ; + return ; +} + + +sub tests_under_docker_context +{ + note( 'Entering tests_under_docker_context()' ) ; + + is( undef, under_docker_context( ), 'under_docker_context: no args => undef' ) ; + + my $mysync = { } ; + $mysync->{ dockercontext } = 1 ; + is( 1, under_docker_context( $mysync ), 'under_docker_context: --dockercontext => 1' ) ; + $mysync->{ dockercontext } = 0 ; + is( 0, under_docker_context( $mysync ), 'under_docker_context: --nodockercontext => 0' ) ; + + $mysync = { } ; + # Is not it a stupid test? + if ( under_docker_context( $mysync ) ) + { + is( 1, under_docker_context( $mysync ), 'under_docker_context: docker context => 1' ) ; + } + else + { + is( 0, under_docker_context( $mysync ), 'under_docker_context: not docker context => 0' ) ; + } + + note( 'Leaving tests_under_docker_context()' ) ; + return ; +} + + +sub under_docker_context +{ + my $mysync = shift @ARG ; + + if ( ! defined $mysync ) { return ; } + + if ( defined $mysync->{ dockercontext } ) + { + return( $mysync->{ dockercontext } ) ; + } + + if ( -e '/.dockerenv' ) + { + return 1 ; + } + else + { + return 0 ; + } + + return ; +} + + +sub docker_context +{ + my $mysync = shift @ARG ; + + if ( ! under_docker_context( $mysync ) ) + { + return ; + } + + output( $mysync, "Docker context detected with the file /.dockerenv\n" ) ; + # No pidfile by default + + $mysync->{ pidfile } = defined( $mysync->{ pidfile } ) ? $mysync->{ pidfile } : q{} ; + # No log by default + if ( defined( $mysync->{ log } ) ) + { + output( $mysync, "Logging in Docker context. Be sure you added access to it with a mount or similar. See https://docs.docker.com/storage/volumes/\n" ) ; + } + else + { + output( $mysync, "No log by default in Docker context. Use --log to trigger logging to the logfile.\n" ) ; + $mysync->{ log } = 0 ; + } + + # In case something is written relatively to . + my $tmp_dir = "/var/tmp/uid_$EFFECTIVE_USER_ID" ; + mkpath( $tmp_dir ) ; # silly? No. it is for imapsync --version being ok. + do_valid_directory( $tmp_dir ) ; + output( $mysync, "Changing current directory to $tmp_dir\n" ) ; + chdir $tmp_dir ; + + return ; +} + +sub cgibegin +{ + my $mysync = shift @ARG ; + if ( ! under_cgi_context( $mysync ) ) { return ; } + require CGI ; + CGI->import( qw( -no_debug -utf8 ) ) ; + require CGI::Carp ; + CGI::Carp->import( qw( fatalsToBrowser ) ) ; + $mysync->{cgi} = CGI->new( ) ; + return ; +} + +sub tests_under_cgi_context +{ + note( 'Entering tests_under_cgi_context()' ) ; + + # $ENV{SERVER_SOFTWARE} = 'under imapsync' ; + do { + # Not in cgi context + delete local $ENV{SERVER_SOFTWARE} ; + is( undef, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE unset => not in cgi context' ) ; + } ; + do { + # In cgi context + local $ENV{SERVER_SOFTWARE} = 'under imapsync' ; + is( 1, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE set => in cgi context' ) ; + } ; + do { + # Not in cgi context + delete local $ENV{SERVER_SOFTWARE} ; + is( undef, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE unset => not in cgi context' ) ; + } ; + do { + # In cgi context + local $ENV{SERVER_SOFTWARE} = 'under imapsync' ; + is( 1, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE set => in cgi context' ) ; + } ; + note( 'Leaving tests_under_cgi_context()' ) ; + return ; +} + + +sub under_cgi_context +{ + my $mysync = shift @ARG ; + # Under cgi context + if ( $ENV{SERVER_SOFTWARE} ) { + return 1 ; + } + # Not in cgi context + return ; +} + +sub cgibuildheader +{ + my $mysync = shift @ARG ; + if ( ! under_cgi_context( $mysync ) ) { return ; } + + my $imapsync_runs = $mysync->{cgi}->cookie( 'imapsync_runs' ) || 0 ; + my $cookie = $mysync->{cgi}->cookie( + -name => 'imapsync_runs', + -value => 1 + $imapsync_runs, + -expires => '+20y', + -path => '/cgi-bin/imapsync', + ) ; + my $httpheader ; + if ( $mysync->{ abort } ) + { + $httpheader = $mysync->{cgi}->header( + -type => 'text/plain; charset=UTF-8', + -status => '200 OK to abort syncing IMAP boxes. ' . load_message( $mysync ), + ) ; + } + elsif( $mysync->{ heavy_load_reached } ) + { +# https://tools.ietf.org/html/rfc2616#section-10.5.4 +# 503 Service Unavailable +# The server is currently unable to handle the request due to a temporary overloading or maintenance of the server. + $httpheader = $mysync->{cgi}->header( + -type => 'text/plain; charset=UTF-8', + -status => '503 Service Unavailable. ' . "Be back later. " . load_message( $mysync ), + ) ; + } + else + { + $httpheader = $mysync->{cgi}->header( + -type => 'text/plain; charset=UTF-8', + -status => '200 OK to sync IMAP boxes. ' . load_message( $mysync ), + -cookie => $cookie, + ) ; + } + output_start( $mysync, $httpheader ) ; + + return ; +} + +sub load_message +{ + my $mysync = shift @ARG ; + + my $message = "Load on " . hostname() . " is $mysync->{ loadavg }" ; + return $message ; +} + +sub cgi_exit_on_heavy_load +{ + # Exit on heavy load in CGI context + my $mysync = shift @ARG ; + if ( ! under_cgi_context( $mysync ) ) { return ; } + if ( $mysync->{ abort } ) { return ; } # keep going to abort since some ressources will be free soon + if ( $mysync->{ heavy_load_reached } ) + { + $mysync->{ nb_errors }++ ; + exit_clean( $mysync, $EX_UNAVAILABLE, + "Server is on heavy load. Be back later. " . load_message( $mysync ) . "\n" + ) ; + } + return ; +} + + + +sub tests_heavy_load_reached +{ + note( 'Entering tests_is_heavy_load_reached()' ) ; + + like( heavy_load_reached( ), qr{^(0|1)$}xms, 'heavy_load_reached: no args => 0 or 1' ) ; + + my $mysync = { } ; + like( heavy_load_reached( $mysync ), qr{^(0|1)$}xms, 'heavy_load_reached: { } => 0 or 1' ) ; + + $mysync->{ exitonload } = 0 ; + is( 0, heavy_load_reached( $mysync ), 'heavy_load_reached: exitonload=0 => 0 ' ) ; + + note( 'Leaving tests_heavy_load_reached()' ) ; + return ; +} + +sub heavy_load_reached +{ + my $mysync = shift @ARG ; + + my $heavy_load_reached = 0 ; + + if ( defined( $mysync->{ exitonload } ) && ( ! $mysync->{ exitonload } ) ) + { + return 0 ; + } + + my $heavy_load_reached_by_memory = heavy_load_reached_by_memory( $mysync ) ; + my $heavy_load_reached_by_cpu = heavy_load_reached_by_cpu( $mysync ) ; + + if ( $heavy_load_reached_by_memory || $heavy_load_reached_by_cpu ) + { + $heavy_load_reached = 1 ; + } + else + { + $heavy_load_reached = 0 ; + } + + return $heavy_load_reached ; +} + + +sub tests_heavy_load_reached_by_cpu +{ + note( 'Entering tests_heavy_load_reached_by_cpu()' ) ; + + note( join( " ", loadavg( ), 'heavy_load_reached_by_cpu ', heavy_load_reached_by_cpu( ) ) ) ; + like( heavy_load_reached_by_cpu( ), qr{^(0|1)$}xms, 'heavy_load_reached_by_cpu: no args => 0 or 1' ) ; + + my $mysync = { } ; + like( heavy_load_reached_by_cpu( $mysync ), qr{^(0|1)$}xms, 'heavy_load_reached_by_cpu: { } => 0 or 1' ) ; + + note( 'Leaving tests_heavy_load_reached_by_cpu()' ) ; + return ; +} + +sub heavy_load_reached_by_cpu +{ + my $mysync = shift @ARG ; + + my $heavy_load_reached = 0 ; + + my $load_and_delay = load_per_cpu( $mysync ) ; + + if ( $load_and_delay ) + { + $heavy_load_reached = 1 ; + } + else + { + $heavy_load_reached = 0 ; + } + + return $heavy_load_reached ; +} + + +sub tests_load_per_cpu +{ + note( 'Entering tests_load_per_cpu()' ) ; + + note( join( " ", 'loadavg:', loadavg( ), 'cpu_number:', cpu_number( ), 'load_per_cpu ', load_per_cpu( ) ) ) ; + like( load_per_cpu( ), qr{^([0-9.]+)$}xms, 'load_per_cpu: no args => number' ) ; + + my $mysync = { } ; + like( load_per_cpu( $mysync ), qr{^([0-9.]+)$}xms, 'load_per_cpu: { } => number' ) ; + + note( 'Leaving tests_load_per_cpu()' ) ; + return ; +} + + +sub load_per_cpu +{ + my $mysync = shift @ARG ; + + return load_and_delay( 1, cpu_number( ), loadavg( ) ) ; +} + +sub tests_heavy_load_reached_by_memory +{ + note( 'Entering tests_heavy_load_reached_by_memory()' ) ; + + like( heavy_load_reached_by_memory( ), qr{^(0|1)$}xms, 'heavy_load_reached_by_memory: no args => 0 or 1' ) ; + + my $mysync = { } ; + like( heavy_load_reached_by_memory( $mysync ), qr{^(0|1)$}xms, 'heavy_load_reached_by_memory: { } => 0 or 1' ) ; + + note( 'Leaving tests_heavy_load_reached_by_memory()' ) ; + return ; +} + + +sub heavy_load_reached_by_memory +{ + my $mysync = shift @ARG ; + + my $heavy_load_reached = 0 ; + + my $heavy_load_percent_threshold = heavy_load_percent_threshold( $mysync ) ; + my $memory_consumption_all_pids_percent = memory_consumption_all_pids_percent( $mysync ) ; + + if ( $memory_consumption_all_pids_percent > $heavy_load_percent_threshold ) + { + $heavy_load_reached = 1 ; + } + else + { + $heavy_load_reached = 0 ; + } + + return $heavy_load_reached ; +} + +sub tests_heavy_load_percent_threshold +{ + note( 'Entering tests_heavy_load_percent_threshold()' ) ; + note( heavy_load_percent_threshold( ) . " (%)" ) ; + like( heavy_load_percent_threshold( ), qr{^\d+$}xms, 'heavy_load_percent_threshold: no args => integer' ) ; + my $mysync = { } ; + like( heavy_load_percent_threshold( ), qr{^\d+$}xms, 'heavy_load_percent_threshold: { } => integer' ) ; + + note( 'Leaving tests_heavy_load_percent_threshold()' ) ; + return ; +} + + +sub heavy_load_percent_threshold +{ + my $mysync = shift @ARG ; + + my $total_memory_bytes = total_ram_memory_bytes( ) || return 0 ; + my $memory_footprint_average_bytes = 250_000_000 ; + my $heavy_load_percent_threshold = max( 0, int( 100 * ( $total_memory_bytes - ( 4 * $memory_footprint_average_bytes ) ) / $total_memory_bytes ) ) ; + + return $heavy_load_percent_threshold ; +} + + + +sub tests_set_umask +{ + note( 'Entering tests_set_umask()' ) ; + + my $save_umask = umask ; + + my $mysync = {} ; + if ( 'MSWin32' eq $OSNAME ) { + is( undef, set_umask( $mysync ), "set_umask: set failure to $UMASK_PARANO on MSWin32" ) ; + }else{ + is( 1, set_umask( $mysync ), "set_umask: set to $UMASK_PARANO" ) ; + } + + umask $save_umask ; + note( 'Leaving tests_set_umask()' ) ; + return ; +} + +sub set_umask +{ + my $mysync = shift @ARG ; + my $previous_umask = umask_str( ) ; + my $new_umask = umask_str( $UMASK_PARANO ) ; + output( $mysync, "Umask set with $new_umask (was $previous_umask)\n" ) ; + if ( $new_umask eq $UMASK_PARANO ) { + return 1 ; + } + return ; +} + +sub tests_umask_str +{ + note( 'Entering tests_umask_str()' ) ; + + my $save_umask = umask ; + + is( umask_str( ), umask_str( ), 'umask_str: no parameters => idopotent' ) ; + is( my $save_umask_str = umask_str( ), umask_str( ), 'umask_str: no parameters => idopotent + save' ) ; + is( '0000', umask_str( q{ } ), 'umask_str: q{ } => 0000' ) ; + is( '0000', umask_str( q{} ), 'umask_str: q{} => 0000' ) ; + is( '0000', umask_str( '0000' ), 'umask_str: 0000 => 0000' ) ; + is( '0000', umask_str( '0' ), 'umask_str: 0 => 0000' ) ; + is( '0200', umask_str( '0200' ), 'umask_str: 0200 => 0200' ) ; + is( '0400', umask_str( '0400' ), 'umask_str: 0400 => 0400' ) ; + is( '0600', umask_str( '0600' ), 'umask_str: 0600 => 0600' ) ; + + SKIP: { + if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests success only for Unix', 6 ) ; } + is( '0100', umask_str( '0100' ), 'umask_str: 0100 => 0100' ) ; + is( '0001', umask_str( '0001' ), 'umask_str: 0001 => 0001' ) ; + is( '0777', umask_str( '0777' ), 'umask_str: 0777 => 0777' ) ; + is( '0777', umask_str( '00777' ), 'umask_str: 00777 => 0777' ) ; + is( '0777', umask_str( ' 777 ' ), 'umask_str: 777 => 0777' ) ; + is( "$UMASK_PARANO", umask_str( $UMASK_PARANO ), "umask_str: UMASK_PARANO $UMASK_PARANO => $UMASK_PARANO" ) ; + } + + is( $save_umask_str, umask_str( $save_umask_str ), 'umask_str: restore with str' ) ; + is( $save_umask, umask, 'umask_str: umask is restored, controlled by direct umask' ) ; + is( $save_umask, umask $save_umask, 'umask_str: umask is restored by direct umask' ) ; + is( $save_umask, umask, 'umask_str: umask initial controlled by direct umask' ) ; + + note( 'Leaving tests_umask_str()' ) ; + return ; +} + +sub umask_str +{ + my $value = shift @ARG ; + + if ( defined $value ) { + umask oct( $value ) ; + } + my $current = umask ; + + return( sprintf( '%#04o', $current ) ) ; +} + +sub tests_umask +{ + note( 'Entering tests_umask()' ) ; + + my $save_umask ; + is( umask, umask, 'umask: umask is umask' ) ; + is( $save_umask = umask, umask, "umask: umask is umask again + save it: $save_umask" ) ; + is( $save_umask, umask oct(0000), 'umask: umask 0000' ) ; + is( oct(0000), umask, 'umask: umask is now 0000' ) ; + is( oct(0000), umask oct(777), 'umask: umask 0777 call, previous 0000' ) ; + + SKIP: { + if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests success only for Unix', 2 ) ; } + is( oct(777), umask, 'umask: umask is now 0777' ) ; + is( oct(777), umask $save_umask, "umask: umask $save_umask restore inital value, previous 0777" ) ; + } + + ok( defined umask $save_umask, "umask: umask $save_umask restore inital value, previous defined" ) ; + is( $save_umask, umask, 'umask: umask is umask restored' ) ; + note( 'Leaving tests_umask()' ) ; + + return ; +} + + +sub make_var_array_to_a_hash +{ + my $mysync = shift @ARG ; + %{ $mysync->{ varh } } = split_around_equal( @{ $mysync->{ var } } ) ; + + return ; +} + + +sub cgisetcontext +{ + my $mysync = shift @ARG ; + if ( ! under_cgi_context( $mysync ) ) { return ; } + + output( $mysync, "Under cgi context\n" ) ; + + + set_umask( $mysync ) ; + + # Remove all content in unsafe evaled options + @{ $mysync->{ regextrans2 } } = ( ) ; + + @{ $mysync->{ regexflag } } = buggyflagsregex( ) ; + + @regexmess = ( ) ; + @skipmess = ( ) ; + @pipemess = ( ) ; + $delete2foldersonly = undef ; + $delete2foldersbutnot = undef ; + $maxlinelengthcmd = undef ; + + # Set safe default values (I hope...) + + + #$mysync->{pidfile} = 'imapsync.pid' ; + $mysync->{ pidfilelocking } = 1 ; + $mysync->{ errorsmax } = $ERRORS_MAX_CGI ; + $modulesversion = 0 ; + $mysync->{ releasecheck } = defined $mysync->{ releasecheck } ? $mysync->{ releasecheck } : 1 ; + $mysync->{ usecache } = 0 ; + $mysync->{ showpasswords } = 0 ; + $mysync->{ acc1 }->{ debugimap } = 0 ; + $mysync->{ acc2 }->{ debugimap } = 0 ; + + $mysync->{ acc1 }->{ reconnectretry } = $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; + $mysync->{ acc2 }->{ reconnectretry } = $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; + + $pipemesscheck = 0 ; + + $mysync->{ hashfile } = $CGI_HASHFILE ; + my $hashsynclocal = hashsynclocal( $mysync ) || die "Can not get hashsynclocal. Exiting\n" ; + + if ( $ENV{ 'NET_SERVER_SOFTWARE' } and ( $ENV{ 'NET_SERVER_SOFTWARE' } =~ /Net::Server::HTTP/ ) ) + { + # under local webserver + $cgidir = q{.} ; + } + else + { + $cgidir = $CGI_TMPDIR_TOP . '/' . $hashsynclocal ; + } + -d $cgidir or mkpath $cgidir or die "Can not create $cgidir: $OS_ERROR\n" ; + $mysync->{ tmpdir } = $cgidir ; + $mysync->{ logdir } = '' ; + + chdir $cgidir or die "Can not cd to $cgidir: $OS_ERROR\n" ; + output( $mysync, cgienvcontext( $mysync ) ) ; + $mysync->{ debug } and output( $mysync, 'Current directory is ' . getcwd( ) . "\n" ) ; + $mysync->{ debug } and output( $mysync, 'Real user id is ' . getpwuid_any_os( $REAL_USER_ID ) . " (uid $REAL_USER_ID)\n" ) ; + $mysync->{ debug } and output( $mysync, 'Effective user id is ' . getpwuid_any_os( $EFFECTIVE_USER_ID ). " (euid $EFFECTIVE_USER_ID)\n" ) ; + + $mysync->{ skipemptyfolders } = defined $mysync->{ skipemptyfolders } ? $mysync->{ skipemptyfolders } : 1 ; + + # Out of memory with messages over 1 GB ? + $mysync->{ maxsize } = defined $mysync->{ maxsize } ? $mysync->{ maxsize } : 1_000_000_000 ; + + # tail -f behaviour on by default + $mysync->{ tail } = defined $mysync->{ tail } ? $mysync->{ tail } : 1 ; + + # not sure it's for good + @useheader = qw( Message-Id Received ) ; + + # addheader on by default + $mysync->{ addheader } = defined $mysync->{ addheader } ? $mysync->{ addheader } : 1 ; + + # sync duplicates by default in cgi context + $mysync->{ syncduplicates } = defined $mysync->{ syncduplicates } ? $mysync->{ syncduplicates } : 1 ; + + # log the logfile name by default in cgi context + $mysync->{ loglogfile } = defined $mysync->{ loglogfile } ? $mysync->{ loglogfile } : 1 ; + + # exit on heavy load + $mysync->{ exitonload } = defined $mysync->{ exitonload } ? $mysync->{ exitonload } : 1 ; + + return ; +} + + + +sub tests_cgienvcontext +{ + note( 'Entering tests_cgienvcontext()' ) ; + + is( '', cgienvcontext( ), 'cgienvcontext: no args => empty' ) ; + my $mysync = { } ; + is( '', cgienvcontext( $mysync ), 'cgienvcontext: undef => empty' ) ; + + # environment SERVER_SOFTWARE alone + local $ENV{SERVER_SOFTWARE} = 'Chateau Lami' ; + is( "SERVER_SOFTWARE is Chateau Lami\n", cgienvcontext( $mysync ), 'cgienvcontext: SERVER_SOFTWARE=Chateau Lami' ) ; + + # environment REMOTE_HOST and SERVER_SOFTWARE + $mysync = { } ; + local $ENV{REMOTE_HOST} = 'Votre serviteur' ; + is( "REMOTE_HOST is Votre serviteur\nSERVER_SOFTWARE is Chateau Lami\n", cgienvcontext( $mysync ), 'cgienvcontext: SERVER_SOFTWARE + REMOTE_HOST' ) ; + + # environment REMOTE_HOST and SERVER_SOFTWARE and --var REMOTE_HOST + $mysync->{ varh }->{REMOTE_HOST} = 'Another Servant' ; + is( "REMOTE_HOST is Another Servant and Votre serviteur\nSERVER_SOFTWARE is Chateau Lami\n", cgienvcontext( $mysync ), 'cgienvcontext: SERVER_SOFTWARE + REMOTE_HOST + --var REMOTE_HOST' ) ; + + + # environment SERVER_SOFTWARE --var REMOTE_HOST only + local $ENV{REMOTE_HOST} = undef ; + $mysync = { } ; + $mysync->{ varh }->{REMOTE_HOST} = 'Another Servant' ; + is( "REMOTE_HOST is Another Servant\nSERVER_SOFTWARE is Chateau Lami\n", cgienvcontext( $mysync ), 'cgienvcontext: SERVER_SOFTWARE + --var REMOTE_HOST' ) ; + + # environment SERVER_SOFTWARE --var REMOTE_HOST only + local $ENV{REMOTE_HOST} = undef ; + local $ENV{SERVER_SOFTWARE} = undef ; + $mysync = { } ; + $mysync->{ varh }->{REMOTE_HOST} = 'Another Servant' ; + is( "REMOTE_HOST is Another Servant\n", cgienvcontext( $mysync ), 'cgienvcontext: --var REMOTE_HOST' ) ; + + note( 'Leaving tests_cgienvcontext()' ) ; + return ; +} + +sub cgienvcontext +{ + my $mysync = shift @ARG ; + + if ( ! defined $mysync ) { return '' ; } + + my $output = '' ; + for my $envvar ( qw( REMOTE_ADDR REMOTE_HOST HTTP_REFERER HTTP_USER_AGENT SERVER_SOFTWARE SERVER_NAME SERVER_ADDR SERVER_PORT SERVER_ADMIN HTTP_COOKIE ) ) + { + # $envval comes from the web server via an environment variable + # $varval comes from the command line parameter --val or the cgi parameter val + my $envval = $ENV{ $envvar } || q{} ; + my $varval = $mysync->{ varh }->{ $envvar } ; + + if ( $envval and not $varval ) + { + $output .= "$envvar is $envval\n" ; + } + elsif ( not $envval and $varval ) + { + $output .= "$envvar is $varval\n" ; + } + elsif ( $envval and $varval ) + { + $output .= "$envvar is $varval and $envval\n" ; + } + } + + return $output ; +} + +sub announcelogfile +{ + my $mysync = shift @ARG ; + + if ( $mysync->{ log } ) + { + myprint( "Log file is $mysync->{ logfile } ( to change it, use --logfile path ; or use --nolog to turn off logging )\n" ) ; + loglogfile( $mysync ) ; + } + else + { + myprint( "No log file because of option --nolog\n" ) ; + } + return ; +} + + + + + + + +sub tests_loglogfile +{ + note( 'Entering tests_loglogfile()' ) ; + + is( undef, loglogfile( ), 'loglogfile: no args => undef' ) ; + my $mysync = { } ; + is( undef, loglogfile( $mysync ), 'loglogfile: undef => undef' ) ; + $mysync->{ loglogfile } = 1 ; + $mysync->{ log } = 1 ; + is( undef, loglogfile( $mysync ), 'loglogfile: no logfile => undef' ) ; + $mysync->{ logfile } = "logfile.txt" ; + $mysync->{ loglogfilename } = "W/tmp/tests/list_all_logs_auto.txt" ; + like( loglogfile( $mysync ), qr{logfile.txt}xms, 'loglogfile: logfile=logfile.txt => ' ) ; + note( 'Leaving tests_loglogfile()' ) ; + return ; +} + + +sub loglogfile +{ + my $mysync = shift @ARG ; + if ( ! $mysync->{ loglogfile } ) { return ; } + if ( ! $mysync->{ log } ) { return ; } + if ( ! $mysync->{ logfile } ) { return ; } + + my $loglogfilename = $mysync->{ loglogfilename } || return ; + + my $absolutelogfilepath = absolutelogfilepath( $mysync ) ; + + if ( condition_to_loglogfile( $mysync ) ) + { + myprint( "Writing log file name $absolutelogfilepath to $loglogfilename\n" ) ; + append_to_file( $absolutelogfilepath, $loglogfilename ) ; + } + + return $absolutelogfilepath ; +} + +sub condition_to_loglogfile +{ + my $mysync = shift @ARG ; + + if ( defined $mysync->{ cmdcgi } and scalar( @{ $mysync->{ cmdcgi } } ) ) + { + return 1 ; + } + else + { + return 0 ; + } +} + +sub absolutelogfilepath +{ + my $mysync = shift @ARG ; + + # Fixme: add case when the logfile name is already absolute + + my $cwd = getcwd( ) ; + my $absolutelogfilepath = "$cwd/$mysync->{ logfile }" ; + + return $absolutelogfilepath ; +} + + +sub append_to_file +{ + my $string = shift @ARG ; + my $filename = shift @ARG ; + + if ( open( my $fh, '>>', $filename ) ) + { + print $fh "$string\n" ; + close $fh ; + } + else + { + myprint( "Could not append $string to file $filename $!\n" ) ; + } + return ; +} + +sub checkselectable +{ + my $mysync = shift @ARG ; + + if ( $mysync->{ checkselectable } ) { + my @h1_folders_wanted_selectable ; + myprint( "Host1: Checking wanted folders are selectable. Use --nocheckselectable to avoid this check.\n" ) ; + foreach my $folder ( @{ $mysync->{ h1_folders_wanted } } ) + { + ( $mysync->{ debug } or $mysync->{ debugfolders } ) and myprint( "Checking $folder is selectable on host1\n" ) ; + # It does an imap command LIST "" $folder and then search for no \Noselect + if ( ! $mysync->{ imap1 }->selectable( $folder ) ) + { + myprint( "Host1: warning! ignoring folder $folder because it is not selectable\n" ) ; + }else + { + push @h1_folders_wanted_selectable, $folder ; + } + } + @{ $mysync->{ h1_folders_wanted } } = @h1_folders_wanted_selectable ; + ( $mysync->{ debug } or $mysync->{ debugfolders } ) + and myprint( 'Host1: checking folders took ', timenext( $mysync ), " s\n" ) ; + } + else + { + myprint( "Host1: Not checking that wanted folders are selectable. Use --checkselectable to force this check.\n" ) ; + } + return ; +} + +sub setcheckselectable +{ + my $mysync = shift @ARG ; + + my $h1_folders_wanted_nb = scalar @{ $mysync->{ h1_folders_wanted } } ; + # 152 because 98% of host1 accounts have less than 152 folders on /X service. + # command to get this value: + # datamash_file_op_index G_Host1_Nb_folders.txt perc:98 4 %16.1f + if ( ! defined $mysync->{ checkselectable } ) + { + if ( 152 >= $h1_folders_wanted_nb ) + { + $mysync->{ checkselectable } = 1 ; + }else{ + myprint( "Host1: Not checking that $h1_folders_wanted_nb wanted folders are selectable. Use --checkselectable to force this check.\n" ) ; + $mysync->{ checkselectable } = 0 ; + } + } + return ; +} + + + +sub debugsleep +{ + my $mysync = shift @ARG ; + if ( defined $mysync->{debugsleep} ) { + myprint( "Info: sleeping $mysync->{debugsleep}s\n" ) ; + sleep $mysync->{debugsleep} ; + } + return ; +} + + + + +# Globals: +# $fetch_hash_set +# +sub foldersize +{ + # size of one folder + my ( $mysync, $side, $imap, $search_cmd, $abletosearch, $folder ) = @ARG ; + + if ( ! all_defined( $mysync, $side, $imap, $folder ) ) + { + return ; + } + + # FTGate is RFC buggy with EXAMINE it does not act as SELECT + #if ( ! $imap->examine( $folder ) ) { + if ( ! $imap->select( $folder ) ) { + my $error = join q{}, + "$side Folder $folder: Could not select: ", + $imap->LastError, "\n" ; + errors_incr( $mysync, $error ) ; + return ; + } + + if ( $imap->IsUnconnected( ) ) + { + return ; + } + + my $hash_ref = { } ; + my @msgs = select_msgs( $imap, undef, $search_cmd, $abletosearch, $folder ) ; + my $nb_msgs = scalar @msgs ; + my $biggest_in_folder = 0 ; + @{ $hash_ref }{ @msgs } = ( undef ) if @msgs ; + + + my $stot = 0 ; + + if ( $imap->IsUnconnected( ) ) + { + return ; + } + + if ( $nb_msgs > 0 and @msgs ) { + if ( $abletosearch ) { + if ( ! $imap->fetch_hash( \@msgs, 'RFC822.SIZE', $hash_ref) ) { + my $error = "$side failure with fetch_hash: $EVAL_ERROR\n" ; + errors_incr( $mysync, $error ) ; + return ; + } + } + else + { + my $fetch_hash_uids = $fetch_hash_set || "1:*" ; + if ( ! $imap->fetch_hash( $fetch_hash_uids, 'RFC822.SIZE', $hash_ref ) ) { + my $error = "$side failure with fetch_hash: $EVAL_ERROR\n" ; + errors_incr( $mysync, $error ) ; + return ; + } + } + for ( keys %{ $hash_ref } ) { + my $size = $hash_ref->{ $_ }->{ 'RFC822.SIZE' } ; + if ( defined $size ) + { + $stot += $size ; + $biggest_in_folder = max( $biggest_in_folder, $size ) ; + } + } + } + return( $stot, $nb_msgs, $biggest_in_folder ) ; + +} + + +# The old subroutine that performed just one side at a time. +# Still here for a while, until confident with sub foldersize_diff_compute() +sub foldersizes +{ + my ( $mysync, $side, $imap, $search_cmd, $abletosearch, @folders ) = @_ ; + my $total_size = 0 ; + my $total_nb = 0 ; + my $biggest_in_all = 0 ; + + my $nb_folders = scalar @folders ; + my $ct_folders = 0 ; # folder counter. + myprint( "++++ Calculating sizes of $nb_folders folders on $side\n" ) ; + foreach my $folder ( @folders ) { + my $stot = 0 ; + my $nb_msgs = 0 ; + my $biggest_in_folder = 0 ; + + $ct_folders++ ; + myprintf( "$side folder %7s %-35s", "$ct_folders/$nb_folders", jux_utf8( $folder ) ) ; + if ( 'Host2' eq $side and not exists $mysync->{h2_folders_all_UPPER}{ uc $folder } ) { + myprint( " does not exist yet\n") ; + next ; + } + if ( 'Host1' eq $side and not exists $h1_folders_all{ $folder } ) { + myprint( " does not exist\n" ) ; + next ; + } + + last if $imap->IsUnconnected( ) ; + + ( $stot, $nb_msgs, $biggest_in_folder ) = foldersize( $mysync, $side, $imap, $search_cmd, $abletosearch, $folder ) ; + + myprintf( ' Size: %9s', $stot ) ; + myprintf( ' Messages: %5s', $nb_msgs ) ; + myprintf( " Biggest: %9s\n", $biggest_in_folder ) ; + $total_size += $stot ; + $total_nb += $nb_msgs ; + $biggest_in_all = max( $biggest_in_all, $biggest_in_folder ) ; + } + myprintf( "%s Nb folders: %11s folders\n", $side, $nb_folders ) ; + myprintf( "%s Nb messages: %11s messages\n", $side, $total_nb ) ; + myprintf( "%s Total size: %11s bytes (%s)\n", $side, $total_size, bytes_display_string_bin( $total_size ) ) ; + myprintf( "%s Biggest message: %11s bytes (%s)\n", $side, $biggest_in_all, bytes_display_string_bin( $biggest_in_all ) ) ; + myprintf( "%s Time spent on sizing: %11.1f seconds\n", $side, timenext( $mysync ) ) ; + return( $total_nb, $total_size ) ; +} + + +sub foldersize_diff_present +{ + my $mysync = shift @ARG ; + my $folder1 = shift @ARG ; + my $folder2 = shift @ARG ; + my $counter_str = shift @ARG ; + my $force = shift @ARG ; + + my $values1_str ; + my $values2_str ; + + if ( ! defined $mysync->{ folder1 }->{ $folder1 }->{ size } || $force ) + { + foldersize_diff_compute( $mysync, $folder1, $folder2, $force ) ; + } + + # again, but this time it means no availaible data. + if ( defined $mysync->{ folder1 }->{ $folder1 }->{ size } ) + { + $values1_str = sprintf( "Size: %9s Messages: %5s Biggest: %9s\n", + $mysync->{ folder1 }->{ $folder1 }->{ size }, + $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs }, + $mysync->{ folder1 }->{ $folder1 }->{ biggest }, + ) ; + } + else + { + $values1_str = " does not exist\n" ; + } + + if ( defined $mysync->{ folder2 }->{ $folder2 }->{ size } ) + { + $values2_str = sprintf( "Size: %9s Messages: %5s Biggest: %9s\n", + $mysync->{ folder2 }->{ $folder2 }->{ size }, + $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs }, + $mysync->{ folder2 }->{ $folder2 }->{ biggest }, + ) ; + } + else + { + $values2_str = " does not exist yet\n" ; + } + + myprintf( "Host1 folder %7s %-35s %s", + "$counter_str", + jux_utf8( $folder1 ), + $values1_str + ) ; + + myprintf( "Host2 folder %7s %-35s %s", + "$counter_str", + jux_utf8( $folder2 ), + $values2_str + ) ; + + myprintf( "Host2-Host1 %7s %-35s %9s %5s %9s\n\n", + "", + "", + $mysync->{ folder1 }->{ $folder1 }->{ size_diff }, + $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs_diff }, + $mysync->{ folder1 }->{ $folder1 }->{ biggest_diff }, + + ) ; + + + + + return ; +} + +sub foldersize_diff_compute +{ + my $mysync = shift @ARG ; + my $folder1 = shift @ARG ; + my $folder2 = shift @ARG ; + my $force = shift @ARG ; + + + + my ( $size_1, $nb_msgs_1, $biggest_1 ) ; + # memoization + if ( + exists $h1_folders_all{ $folder1 } + && + ( + ! defined $mysync->{ folder1 }->{ $folder1 }->{ size } + || $force + ) + ) + { + #myprint( "foldersize folder1 $h1_folders_all{ $folder1 }\n" ) ; + ( $size_1, $nb_msgs_1, $biggest_1 ) = + foldersize( $mysync, + 'Host1', + $mysync->{ imap1 }, + $mysync->{ search1 }, + $mysync->{ abletosearch1 }, + $folder1 + ) ; + $mysync->{ folder1 }->{ $folder1 }->{ size } = $size_1 ; + $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs } = $nb_msgs_1 ; + $mysync->{ folder1 }->{ $folder1 }->{ biggest } = $biggest_1 ; + } + else + { + $size_1 = $mysync->{ folder1 }->{ $folder1 }->{ size } ; + $nb_msgs_1 = $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs } ; + $biggest_1 = $mysync->{ folder1 }->{ $folder1 }->{ biggest } ; + + } + + + my ( $size_2, $nb_msgs_2, $biggest_2 ) ; + if ( + exists $mysync->{ h2_folders_all_UPPER }{ uc $folder2 } + && + ( + ! defined $mysync->{ folder2 }->{ $folder2 }->{ size } + || $force + ) + ) + { + #myprint( "foldersize folder2\n" ) ; + ( $size_2, $nb_msgs_2, $biggest_2 ) = + foldersize( $mysync, + 'Host2', + $mysync->{ imap2 }, + $mysync->{ search2 }, + $mysync->{ abletosearch2 }, + $folder2 + ) ; + + $mysync->{ folder2 }->{ $folder2 }->{ size } = $size_2 ; + $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs } = $nb_msgs_2 ; + $mysync->{ folder2 }->{ $folder2 }->{ biggest } = $biggest_2 ; + } + else + { + $size_2 = $mysync->{ folder2 }->{ $folder2 }->{ size } ; + $nb_msgs_2 = $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs } ; + $biggest_2 = $mysync->{ folder2 }->{ $folder2 }->{ biggest } ; + + } + + + my $size_diff = diff( $size_2, $size_1 ) ; + my $nb_msgs_diff = diff( $nb_msgs_2, $nb_msgs_1 ) ; + my $biggest_diff = diff( $biggest_2, $biggest_1 ) ; + + $mysync->{ folder1 }->{ $folder1 }->{ size_diff } = $size_diff ; + $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs_diff } = $nb_msgs_diff ; + $mysync->{ folder1 }->{ $folder1 }->{ biggest_diff } = $biggest_diff ; + + # It's redundant but easier to access later + $mysync->{ folder2 }->{ $folder2 }->{ size_diff } = $size_diff ; + $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs_diff } = $nb_msgs_diff ; + $mysync->{ folder2 }->{ $folder2 }->{ biggest_diff } = $biggest_diff ; + + return ; +} + +sub diff +{ + my $x = shift @ARG ; + my $y = shift @ARG ; + + $x ||= 0 ; + $y ||= 0 ; + + return $x - $y ; +} + +sub tests_add +{ + note( 'Entering tests_add()' ) ; + + is( 0, add( ), 'tests_add: no args => 0' ) ; + is( 0, add( undef ), 'tests_add: undef => 0' ) ; + is( 0, add( 0 ), 'tests_add: 0 => 0' ) ; + is( 0, add( 0, 0 ), 'tests_add: 0 0 => 0' ) ; + is( 0, add( 0, 0, 0 ), 'tests_add: 0 0 0 => 0' ) ; + is( 1, add( 1 ), 'tests_add: 1 => 1' ) ; + is( 2, add( 1, 1 ), 'tests_add: 1 1 => 2' ) ; + is( 3, add( 1, 1, 1 ), 'tests_add: 1 1 1 => 3' ) ; + is( 2, add( 1, undef, 1 ), 'tests_add: 1 undef 1 => 2' ) ; + is( 0, add( -1, 1 ), 'tests_add: -1 1 => 0' ) ; + + is( 2.2, add( 1.1, 1.1 ), 'tests_add: 1.1 1.1 => 2.2' ) ; + + is( 100, add( (1) x 100 ), 'tests_add: 1 1 ... 1 100 times => 100 list' ) ; + my @hundred_ones = (1) x 100 ; + is( 100, add( @hundred_ones ), 'tests_add: 1 1 ... 1 100 times => 100 array' ) ; + + note( 'Leaving tests_add()' ) ; + return ; +} + + +sub add +{ + my $sum = 0 ; + foreach my $number ( @ARG ) + { + $sum += $number || 0 ; + } + return $sum ; +} + +sub tests_checknoabletosearch +{ + note( 'Entering checknoabletosearch()' ) ; + + is( undef, checknoabletosearch( ), 'checknoabletosearch: no args => undef' ) ; + + note( 'Leaving checknoabletosearch()' ) ; + return ; +} + + + + +sub checknoabletosearch +{ + # call example: checknoabletosearch( $sync, $sync->{ imap1 }, 'INBOX', 'Host1' ) ; + # output: + # * undef if something is not ok to decide + # * 1 if SEARCH ALL failed + + my( $mysync, $imap, $folder, $HostX ) = @ARG ; + + if ( ! all_defined( $mysync, $imap, $folder, $HostX ) ) + { + return ; + } + + myprint( "$HostX: checking if SEARCH ALL works on $folder\n" ) ; + if ( ! select_folder( $mysync, $imap, $folder, $HostX ) ) + { + myprint( "$HostX: can not SELECT folder [$folder]\n" ) ; + return ; + } + my $count_from_select = count_from_select( $imap->History ) ; + myprint( "$HostX: folder [$folder] has $count_from_select messages mentioned by SELECT\n" ) ; + + my $msgs_all = $imap->messages( ) ; + if ( ! $msgs_all ) + { + myprint( "$HostX: can not SEARCH ALL folder [$folder]\n" ) ; + myprint( "$HostX: ", $imap->LastError(), "\n" ) ; + return 1 ; + } + + my $count_from_search_all = scalar( @{ $msgs_all } ) ; + myprint( "$HostX: folder [$folder] has $count_from_search_all messages found by SEARCH ALL\n" ) ; + + if ( $count_from_select == $count_from_search_all ) + { + myprint( "$HostX: folder [$folder] has the same messages count ($count_from_select) by SELECT and SEARCH ALL\n" ) ; + } + else + { + myprint( "$HostX: Warning, folder [$folder] has not the same count by SELECT ($count_from_select) and SEARCH ALL ($count_from_search_all)\n" ) ; + return 1 ; + } + + return ; +} + + +sub foldersizes_diff_list +{ + my $mysync = shift @ARG ; + my $force = shift @ARG ; + + my @folders = @{ $mysync->{h1_folders_wanted} } ; + my $nb_folders = scalar @folders ; + my $ct_folders = 0 ; # folder counter. + + foreach my $folder1 ( @folders ) + { + $ct_folders++ ; + my $counter_str = "$ct_folders/$nb_folders" ; + my $folder2 = imap2_folder_name( $mysync, $folder1 ) ; + foldersize_diff_present( $mysync, $folder1, $folder2, $counter_str, $force ) ; + } + + return ; +} + +sub foldersizes_total +{ + my $mysync = shift @ARG ; + + my @folders_1 = @{ $mysync->{h1_folders_wanted} } ; + my @folders_2 = @h2_folders_from_1_wanted ; + + my $nb_folders_1 = scalar( @folders_1 ) ; + my $nb_folders_2 = scalar( @folders_2 ) ; + + my ( $total_size_1, $total_nb_1, $biggest_in_all_1 ) = ( 0, 0, 0 ) ; + my ( $total_size_2, $total_nb_2, $biggest_in_all_2 ) = ( 0, 0, 0 ) ; + + foreach my $folder1 ( @folders_1 ) + { + $total_size_1 = add( $total_size_1, $mysync->{ folder1 }->{ $folder1 }->{ size } ) ; + $total_nb_1 = add( $total_nb_1, $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs } ) ; + $biggest_in_all_1 = max( $biggest_in_all_1 , $mysync->{ folder1 }->{ $folder1 }->{ biggest } ) ; + } + + foreach my $folder2 ( @folders_2 ) + { + $total_size_2 = add( $total_size_2, $mysync->{ folder2 }->{ $folder2 }->{ size } ) ; + $total_nb_2 = add( $total_nb_2, $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs } ) ; + $biggest_in_all_2 = max( $biggest_in_all_2 , $mysync->{ folder2 }->{ $folder2 }->{ biggest } ) ; + + } + + myprintf( "Host1 Nb folders: %11s folders\n", $nb_folders_1 ) ; + myprintf( "Host2 Nb folders: %11s folders\n", $nb_folders_2 ) ; + myprint( "\n" ) ; + myprintf( "Host1 Nb messages: %11s messages\n", $total_nb_1 ) ; + myprintf( "Host2 Nb messages: %11s messages\n", $total_nb_2 ) ; + myprint( "\n" ) ; + myprintf( "Host1 Total size: %11s bytes (%s)\n", $total_size_1, bytes_display_string_bin( $total_size_1 ) ) ; + myprintf( "Host2 Total size: %11s bytes (%s)\n", $total_size_2, bytes_display_string_bin( $total_size_2 ) ) ; + myprint( "\n" ) ; + myprintf( "Host1 Biggest message: %11s bytes (%s)\n", $biggest_in_all_1, bytes_display_string_bin( $biggest_in_all_1 ) ) ; + myprintf( "Host2 Biggest message: %11s bytes (%s)\n", $biggest_in_all_2, bytes_display_string_bin( $biggest_in_all_2 ) ) ; + myprint( "\n" ) ; + myprintf( "Time spent on sizing: %11.1f seconds\n", timenext( $mysync ) ) ; + + my @total_1_2 = ( $total_nb_1, $total_size_1, $total_nb_2, $total_size_2 ) ; + return @total_1_2 ; +} + +sub foldersizesatend_old +{ + my $mysync = shift @ARG ; + timenext( $mysync ) ; + return if ( $mysync->{imap1}->IsUnconnected( ) ) ; + return if ( $mysync->{imap2}->IsUnconnected( ) ) ; + # Get all folders on host2 again since new were created + @h2_folders_all = sort $mysync->{imap2}->folders(); + for ( @h2_folders_all ) { + $h2_folders_all{ $_ } = 1 ; + $mysync->{h2_folders_all_UPPER}{ uc $_ } = 1 ; + } ; + ( $h1_nb_msg_end, $h1_bytes_end ) = foldersizes( $mysync, 'Host1', $mysync->{imap1}, $mysync->{ search1 }, $mysync->{abletosearch1}, @{ $mysync->{h1_folders_wanted} } ) ; + ( $h2_nb_msg_end, $h2_bytes_end ) = foldersizes( $mysync, 'Host2', $mysync->{imap2}, $mysync->{ search2 }, $mysync->{abletosearch2}, @h2_folders_from_1_wanted ) ; + if ( not all_defined( $h1_nb_msg_end, $h1_bytes_end, $h2_nb_msg_end, $h2_bytes_end ) ) { + my $error = "Failure getting foldersizes, final differences will not be calculated\n" ; + errors_incr( $mysync, $error ) ; + } + return ; +} + +sub foldersizesatend +{ + my $mysync = shift @ARG ; + timenext( $mysync ) ; + return if ( $mysync->{imap1}->IsUnconnected( ) ) ; + return if ( $mysync->{imap2}->IsUnconnected( ) ) ; + # Get all folders on host2 again since new were created + @h2_folders_all = sort $mysync->{imap2}->folders(); + for ( @h2_folders_all ) { + $h2_folders_all{ $_ } = 1 ; + $mysync->{h2_folders_all_UPPER}{ uc $_ } = 1 ; + } ; + + + foldersizes_diff_list( $mysync, $FORCE ) ; + + ( $h1_nb_msg_end, $h1_bytes_end, $h2_nb_msg_end, $h2_bytes_end ) + = foldersizes_total( $mysync ) ; + + + if ( not all_defined( $h1_nb_msg_end, $h1_bytes_end, $h2_nb_msg_end, $h2_bytes_end ) ) { + my $error = "Failure getting foldersizes, final differences will not be calculated\n" ; + errors_incr( $mysync, $error ) ; + } + return ; +} + + +sub foldersizes_at_the_beggining +{ + my $mysync = shift @ARG ; + + myprint( << 'END_SIZE' ) ; + +Folders sizes before the synchronization. It can take some time. Be patient. +You can remove foldersizes listings by using "--nofoldersizes" and "--nofoldersizesatend" +but then you will also lose the ETA (Estimation Time of Arrival) given after each message copy. +END_SIZE + + foldersizes_diff_list( $mysync ) ; + + ( $mysync->{ h1_nb_msg_start }, $mysync->{ h1_bytes_start }, + $mysync->{ h2_nb_msg_start }, $mysync->{ h2_bytes_start } ) + = foldersizes_total( $mysync ) ; + + + if ( not all_defined( + $mysync->{ h1_nb_msg_start }, + $mysync->{ h1_bytes_start }, + $mysync->{ h2_nb_msg_start }, + $mysync->{ h2_bytes_start } ) ) + { + my $error = "Failure getting foldersizes, ETA and final diff will not be displayed\n" ; + errors_incr( $mysync, $error ) ; + $mysync->{ foldersizes } = 0 ; + $mysync->{ foldersizesatend } = 0 ; + return ; + } + + my $h2_bytes_limit = $mysync->{ acc2 }->{quota_limit_bytes} || 0 ; + if ( $h2_bytes_limit and ( $h2_bytes_limit < $mysync->{ h1_bytes_start } ) ) + { + my $quota_percent = mysprintf( '%.0f', $NUMBER_100 * $mysync->{ h1_bytes_start } / $h2_bytes_limit ) ; + my $error = "Host2: Quota limit will be exceeded! Over $quota_percent % ( $mysync->{ h1_bytes_start } bytes / $h2_bytes_limit bytes )\n" ; + errors_incr( $mysync, $error ) ; + } + return ; +} + + +# Globals: +# @h2_folders_from_1_wanted + +sub foldersizes_at_the_beggining_old +{ + my $mysync = shift @ARG ; + + myprint( << 'END_SIZE' ) ; + +Folders sizes before the synchronization. +You can remove foldersizes listings by using "--nofoldersizes" and "--nofoldersizesatend" +but then you will also lose the ETA (Estimation Time of Arrival) given after each message copy. +END_SIZE + + ( $mysync->{ h1_nb_msg_start }, $mysync->{ h1_bytes_start } ) = + foldersizes( $mysync, 'Host1', $mysync->{imap1}, $mysync->{ search1 }, + $mysync->{abletosearch1}, @{ $mysync->{h1_folders_wanted} } ) ; + ( $mysync->{ h2_nb_msg_start }, $mysync->{ h2_bytes_start } ) = + foldersizes( $mysync, 'Host2', $mysync->{imap2}, $mysync->{ search2 }, + $mysync->{abletosearch2}, @h2_folders_from_1_wanted ) ; + + if ( not all_defined( $mysync->{ h1_nb_msg_start }, + $mysync->{ h1_bytes_start }, $mysync->{ h2_nb_msg_start }, $mysync->{ h2_bytes_start } ) ) + { + my $error = "Failure getting foldersizes, ETA and final diff will not be displayed\n" ; + errors_incr( $mysync, $error ) ; + $mysync->{ foldersizes } = 0 ; + $mysync->{ foldersizesatend } = 0 ; + return ; + } + + my $h2_bytes_limit = $mysync->{ acc2 }->{quota_limit_bytes} || 0 ; + if ( $h2_bytes_limit and ( $h2_bytes_limit < $mysync->{ h1_bytes_start } ) ) + { + my $quota_percent = mysprintf( '%.0f', $NUMBER_100 * $mysync->{ h1_bytes_start } / $h2_bytes_limit ) ; + my $error = "Host2: Quota limit will be exceeded! Over $quota_percent % ( $mysync->{ h1_bytes_start } bytes / $h2_bytes_limit bytes )\n" ; + errors_incr( $mysync, $error ) ; + } + return ; +} + + +sub tests_total_bytes_max_reached +{ + note( 'Entering tests_total_bytes_max_reached()' ) ; + + is( undef, total_bytes_max_reached( ), 'total_bytes_max_reached: no args => undef' ) ; + + my $mysync = {} ; + is( undef, total_bytes_max_reached( $mysync ), 'total_bytes_max_reached: no exitwhenover => undef' ) ; + + $mysync->{ exitwhenover } = 300 ; + is( undef, total_bytes_max_reached( $mysync ), 'total_bytes_max_reached: exitwhenover 300 but no total_bytes_transferred => undef' ) ; + + $mysync->{ total_bytes_transferred } = 200 ; + is( undef, total_bytes_max_reached( $mysync ), 'total_bytes_max_reached: exitwhenover 300 but total_bytes_transferred 200 => undef' ) ; + + $mysync->{ total_bytes_transferred } = 400 ; + is( 1, total_bytes_max_reached( $mysync ), 'total_bytes_max_reached: exitwhenover 300 but total_bytes_transferred 400 => 1' ) ; + + + + note( 'Leaving tests_total_bytes_max_reached()' ) ; + return ; +} + + +sub total_bytes_max_reached +{ + my $mysync = shift @ARG ; + + if ( ! defined $mysync ) { return ; } + + if ( ! $mysync->{ exitwhenover } ) + { + return ; + } + + if ( ! $mysync->{ total_bytes_transferred } ) + { + return ; + } + + if ( $mysync->{ total_bytes_transferred } >= $mysync->{ exitwhenover } ) + { + my $error = "Maximum bytes transferred reached, $mysync->{total_bytes_transferred} >= $mysync->{ exitwhenover }, ending sync\n" ; + errors_incr( $mysync, $error ) ; + return( 1 ) ; + } + return ; +} + + +sub tests_mock_capability +{ + note( 'Entering tests_mock_capability()' ) ; + + my $myimap ; + ok( $myimap = mock_capability( ), + 'mock_capability: (1) no args => a Test::MockObject' + ) ; + ok( $myimap->isa( 'Test::MockObject' ), + 'mock_capability: (2) no args => a Test::MockObject' + ) ; + + is( undef, $myimap->capability( ), + 'mock_capability: (3) no args => capability undef' + ) ; + + ok( mock_capability( $myimap ), + 'mock_capability: (1) one arg => MockObject' + ) ; + + is( undef, $myimap->capability( ), + 'mock_capability: (2) one arg OO style => capability undef' + ) ; + + ok( mock_capability( $myimap, $NUMBER_123456 ), + 'mock_capability: (1) two args 123456 => capability 123456' + ) ; + + is( $NUMBER_123456, $myimap->capability( ), + 'mock_capability: (2) two args 123456 => capability 123456' + ) ; + + ok( mock_capability( $myimap, 'ABCD' ), + 'mock_capability: (1) two args ABCD => capability ABCD' + ) ; + is( 'ABCD', $myimap->capability( ), + 'mock_capability: (2) two args ABCD => capability ABCD' + ) ; + + ok( mock_capability( $myimap, [ 'ABCD' ] ), + 'mock_capability: (1) two args [ ABCD ] => capability [ ABCD ]' + ) ; + is_deeply( [ 'ABCD' ], $myimap->capability( ), + 'mock_capability: (2) two args [ ABCD ] => capability [ ABCD ]' + ) ; + + ok( mock_capability( $myimap, [ 'ABC', 'DEF' ] ), + 'mock_capability: (1) two args [ ABC, DEF ] => capability [ ABC, DEF ]' + ) ; + is_deeply( [ 'ABC', 'DEF' ], $myimap->capability( ), + 'mock_capability: (2) two args [ ABC, DEF ] => capability capability [ ABC, DEF ]' + ) ; + + ok( mock_capability( $myimap, 'ABC', 'DEF' ), + 'mock_capability: (1) two args ABC, DEF => capability [ ABC, DEF ]' + ) ; + is_deeply( [ 'ABC', 'DEF' ], [ $myimap->capability( ) ], + 'mock_capability: (2) two args ABC, DEF => capability capability [ ABC, DEF ]' + ) ; + + ok( mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ), + 'mock_capability: (1) two args IMAP4rev1, APPENDLIMIT=123456 => capability [ IMAP4rev1, APPENDLIMIT=123456 ]' + ) ; + is_deeply( [ 'IMAP4rev1', 'APPENDLIMIT=123456' ], [ $myimap->capability( ) ], + 'mock_capability: (2) two args IMAP4rev1, APPENDLIMIT=123456 => capability capability [ IMAP4rev1, APPENDLIMIT=123456 ]' + ) ; + + note( 'Leaving tests_mock_capability()' ) ; + return ; +} + +sub sig_install_toggle_sleep +{ + my $mysync = shift @ARG ; + if ( 'MSWin32' ne $OSNAME ) { + #myprint( "sig_install( $mysync, \&toggle_sleep, 'USR1' )\n" ) ; + sig_install( $mysync, 'toggle_sleep', 'USR1' ) ; + } + #myprint( "Leaving sig_install_toggle_sleep\n" ) ; + return ; +} + + +sub mock_capability +{ + my $myimap = shift @ARG ; + my @has_capability_value = @ARG ; + my ( $has_capability_value ) = @has_capability_value ; + + if ( ! $myimap ) + { + require_ok( "Test::MockObject" ) ; + $myimap = Test::MockObject->new( ) ; + } + + $myimap->mock( + 'capability', + sub { return wantarray ? + @has_capability_value + : $has_capability_value ; + } + ) ; + + return $myimap ; +} + + +sub tests_capability_of +{ + note( 'Entering tests_capability_of()' ) ; + + is( undef, capability_of( ), + 'capability_of: no args => undef' ) ; + + my $myimap ; + is( undef, capability_of( $myimap ), + 'capability_of: undef => undef' ) ; + + + $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ; + + is( undef, capability_of( $myimap, 'CACA' ), + 'capability_of: two args unknown capability => undef' ) ; + + + is( $NUMBER_123456, capability_of( $myimap, 'APPENDLIMIT' ), + 'capability_of: two args APPENDLIMIT 123456 => 123456 yeah!' ) ; + + note( 'Leaving tests_capability_of()' ) ; + return ; +} + + +sub capability_of +{ + my $imap = shift || return ; + my $capability_keyword = shift || return ; + + my @capability = $imap->capability ; + + if ( ! @capability ) { return ; } + my $capability_value = search_in_array( $capability_keyword, @capability ) ; + + return $capability_value ; +} + + +sub tests_search_in_array +{ + note( 'Entering tests_search_in_array()' ) ; + + is( undef, search_in_array( 'KA' ), + 'search_in_array: no array => undef ' ) ; + + is( 'VA', search_in_array( 'KA', ( 'KA=VA' ) ), + 'search_in_array: KA KA=VA => VA ' ) ; + + is( 'VA', search_in_array( 'KA', ( 'KA=VA', 'KB=VB' ) ), + 'search_in_array: KA KA=VA KB=VB => VA ' ) ; + + is( 'VB', search_in_array( 'KB', ( 'KA=VA', 'KB=VB' ) ), + 'search_in_array: KA=VA KB=VB => VB ' ) ; + + note( 'Leaving tests_search_in_array()' ) ; + return ; +} + +sub search_in_array +{ + my ( $key, @array ) = @ARG ; + + foreach my $item ( @array ) + { + + if ( $item =~ /([^=]+)=(.*)/ ) + { + if ( $1 eq $key ) + { + return $2 ; + } + } + } + + return ; +} + + + + +sub tests_appendlimit_from_capability +{ + note( 'Entering tests_appendlimit_from_capability()' ) ; + + is( undef, appendlimit_from_capability( ), + 'appendlimit_from_capability: no args => undef' + ) ; + + my $myimap ; + is( undef, appendlimit_from_capability( $myimap ), + 'appendlimit_from_capability: undef arg => undef' + ) ; + + + $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ; + + # Normal behavior + is( $NUMBER_123456, appendlimit_from_capability( $myimap ), + 'appendlimit_from_capability: APPENDLIMIT=123456 => 123456' + ) ; + + # Not a number + $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=ABC' ) ; + + is( undef, appendlimit_from_capability( $myimap ), + 'appendlimit_from_capability: not a number => undef' + ) ; + + note( 'Leaving tests_appendlimit_from_capability()' ) ; + return ; +} + + +sub appendlimit_from_capability +{ + my $myimap = shift @ARG ; + if ( ! $myimap ) + { + myprint( "Warn: no imap with call to appendlimit_from_capability\n" ) ; + return ; + } + + #myprint( Data::Dumper->Dump( [ \$myimap ] ) ) ; + my $appendlimit = capability_of( $myimap, 'APPENDLIMIT' ) ; + #myprint( "has_capability APPENDLIMIT $appendlimit\n" ) ; + if ( is_integer( $appendlimit ) ) + { + return $appendlimit ; + } + return ; +} + + +sub tests_appendlimit +{ + note( 'Entering tests_appendlimit()' ) ; + + is( undef, appendlimit( ), + 'appendlimit: no args => undef' + ) ; + + my $mysync = { } ; + + is( undef, appendlimit( $mysync ), + 'appendlimit: no imap2 => undef' + ) ; + + my $myimap ; + $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ; + + $mysync->{ imap2 } = $myimap ; + + is( 123456, appendlimit( $mysync ), + 'appendlimit: imap2 with APPENDLIMIT=123456 => 123456' + ) ; + + note( 'Leaving tests_appendlimit()' ) ; + return ; +} + +sub appendlimit +{ + my $mysync = shift || return ; + my $myimap = $mysync->{ imap2 } ; + + my $appendlimit = appendlimit_from_capability( $myimap ) ; + if ( defined $appendlimit ) + { + myprint( "Host2: found APPENDLIMIT=$appendlimit in CAPABILITY (use --appendlimit xxxx to override this automatic setting)\n" ) ; + return $appendlimit ; + } + return ; + +} + + +sub tests_maxsize_setting +{ + note( 'Entering tests_maxsize_setting()' ) ; + + is( undef, maxsize_setting( ), + 'maxsize_setting: no args => undef' + ) ; + + my $mysync ; + + is( undef, maxsize_setting( $mysync ), + 'maxsize_setting: undef arg => undef' + ) ; + + $mysync = { } ; + $mysync->{ maxsize } = $NUMBER_123456 ; + + # --maxsize alone + is( $NUMBER_123456, maxsize_setting( $mysync ), + 'maxsize_setting: --maxsize 123456 alone => 123456' + ) ; + + + $mysync = { } ; + my $myimap ; + + $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=654321' ) ; + $mysync->{ imap2 } = $myimap ; + + # APPENDLIMIT alone + is( $NUMBER_654321, maxsize_setting( $mysync ), + 'maxsize_setting: APPENDLIMIT 654321 alone => 654321' + ) ; + + is( $NUMBER_654321, $mysync->{ maxsize }, + 'maxsize_setting: APPENDLIMIT 654321 alone => maxsize 654321' + ) ; + + # APPENDLIMIT with --appendlimit => --appendlimit wins + $mysync->{ appendlimit } = $NUMBER_123456 ; + + is( $NUMBER_123456, maxsize_setting( $mysync ), + 'maxsize_setting: APPENDLIMIT 654321 + --appendlimit 123456 => 123456' + ) ; + + is( $NUMBER_123456, $mysync->{ maxsize }, + 'maxsize_setting: APPENDLIMIT 654321 + --appendlimit 123456 => maxsize 123456' + ) ; + + # Fresh + $mysync = { } ; + $mysync->{ imap2 } = $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=654321' ) ; + + # Case: "APPENDLIMIT >= --maxsize" => maxsize. + $mysync->{ maxsize } = $NUMBER_123456 ; + + is( $NUMBER_123456, maxsize_setting( $mysync ), + 'maxsize_setting: APPENDLIMIT 654321 --maxsize 123456 => 123456' + ) ; + + # Case: "APPENDLIMIT < --maxsize" => APPENDLIMIT. + + + # Fresh + $mysync = { } ; + $mysync->{ imap2 } = $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ; + $mysync->{ maxsize } = $NUMBER_654321 ; + + is( $NUMBER_123456, maxsize_setting( $mysync ), + 'maxsize_setting: APPENDLIMIT 123456 --maxsize 654321 => 123456 ' + ) ; + + # Now --truncmess stuff + + note( 'Leaving tests_maxsize_setting()' ) ; + + return ; +} + +# Three variables to take account of +# appendlimit (given by --appendlimit or CAPABILITY...) +# maxsize +# truncmess + +sub maxsize_setting +{ + my $mysync = shift || return ; + + if ( defined $mysync->{ appendlimit } ) + { + myprint( "Host2: Getting appendlimit from --appendlimit $mysync->{ appendlimit }\n" ) ; + } + else + { + $mysync->{ appendlimit } = appendlimit( $mysync ) ; + } + + + if ( all_defined( $mysync->{ appendlimit }, $mysync->{ maxsize } ) ) + { + my $min_maxsize_appendlimit = min( $mysync->{ maxsize }, $mysync->{ appendlimit } ) ; + myprint( "Host2: Setting maxsize to $min_maxsize_appendlimit (min of --maxsize $mysync->{ maxsize } and appendlimit $mysync->{ appendlimit }\n" ) ; + $mysync->{ maxsize } = $min_maxsize_appendlimit ; + return $mysync->{ maxsize } ; + } + elsif ( defined $mysync->{ appendlimit } ) + { + myprint( "Host2: Setting maxsize to appendlimit $mysync->{ appendlimit }\n" ) ; + $mysync->{ maxsize } = $mysync->{ appendlimit } ; + return $mysync->{ maxsize } ; + }elsif ( defined $mysync->{ maxsize } ) + { + return $mysync->{ maxsize } ; + }else + { + return ; + } +} + + + + +sub all_defined +{ + if ( not @ARG ) { + return 0 ; + } + foreach my $elem ( @ARG ) { + if ( not defined $elem ) { + return 0 ; + } + } + return 1 ; +} + +sub tests_all_defined +{ + note( 'Entering tests_all_defined()' ) ; + + is( 0, all_defined( ), 'all_defined: no param => 0' ) ; + is( 0, all_defined( () ), 'all_defined: void list => 0' ) ; + is( 0, all_defined( undef ), 'all_defined: undef => 0' ) ; + is( 0, all_defined( undef, undef ), 'all_defined: undef => 0' ) ; + is( 0, all_defined( 1, undef ), 'all_defined: 1 undef => 0' ) ; + is( 0, all_defined( undef, 1 ), 'all_defined: undef 1 => 0' ) ; + is( 1, all_defined( 1, 1 ), 'all_defined: 1 1 => 1' ) ; + is( 1, all_defined( (1, 1) ), 'all_defined: (1 1) => 1' ) ; + + note( 'Leaving tests_all_defined()' ) ; + return ; +} + + +sub tests_hashsynclocal +{ + note( 'Entering tests_hashsynclocal()' ) ; + + my $mysync = { + host1 => q{}, + user1 => q{}, + password1 => q{}, + host2 => q{}, + user2 => q{}, + password2 => q{}, + } ; + + is( undef, hashsynclocal( $mysync ), 'hashsynclocal: no hashfile name' ) ; + + $mysync->{ hashfile } = q{} ; + is( undef, hashsynclocal( $mysync ), 'hashsynclocal: empty hashfile name' ) ; + + $mysync->{ hashfile } = './noexist/rrr' ; + is( undef, hashsynclocal( $mysync ), 'hashsynclocal: no exists hashfile dir' ) ; + + SKIP: { + if ( 'MSWin32' eq $OSNAME or '0' eq $EFFECTIVE_USER_ID ) { skip( 'Tests only for non-root Unix', 1 ) ; } + $mysync->{ hashfile } = '/rrr' ; + is( undef, hashsynclocal( $mysync ), 'hashsynclocal: permission denied' ) ; + } + ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'hashsynclocal: mkpath W/tmp/tests/' ) ; + $mysync->{ hashfile } = 'W/tmp/tests/imapsync_hash' ; + + ok( ! -e 'W/tmp/tests/imapsync_hash' || unlink 'W/tmp/tests/imapsync_hash', 'hashsynclocal: unlink W/tmp/tests/imapsync_hash' ) ; + ok( ! -e 'W/tmp/tests/imapsync_hash', 'hashsynclocal: verify there is no W/tmp/tests/imapsync_hash' ) ; + is( 'ecdeb4ede672794d173da4e08c52b8ee19b7d252', hashsynclocal( $mysync, 'mukksyhpmbixkxkpjlqivmlqsulpictj' ), 'hashsynclocal: creating/reading W/tmp/tests/imapsync_hash' ) ; + # A second time now + is( 'ecdeb4ede672794d173da4e08c52b8ee19b7d252', hashsynclocal( $mysync ), 'hashsynclocal: reading W/tmp/tests/imapsync_hash second time => same' ) ; + + note( 'Leaving tests_hashsynclocal()' ) ; + return ; +} + +sub hashsynclocal +{ + my $mysync = shift @ARG ; + my $hashkey = shift @ARG ; # Optional, only there for tests + my $hashfile = $mysync->{ hashfile } ; + $hashfile = createhashfileifneeded( $hashfile, $hashkey ) ; + if ( ! $hashfile ) { + return ; + } + $hashkey = firstline( $hashfile ) ; + if ( ! $hashkey ) { + myprint( "No hashkey!\n" ) ; + return ; + } + my $hashsynclocal = hashsync( $mysync, $hashkey ) ; + return( $hashsynclocal ) ; + +} + +sub tests_hashsync +{ + note( 'Entering tests_hashsync()' ) ; + + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hashsync( ), 'hashsync: no args' ) ; + + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hashsync( {}, q{} ), 'hashsync: empty args' ) ; + my $mysync ; + $mysync->{ host1 } = 'zzz' ; + is( 'e86a28a3611c1e7bbaf8057cd00ae122781a11fe', hashsync( $mysync, q{} ), 'hashsync: host1 zzz => ' ) ; + is( '6a7b451ac99eab1531ad8e6cd544b32420c552ac', hashsync( $mysync, q{A} ), 'hashsync: host1 zzz => ' ) ; + $mysync->{ host2 } = 'zzz' ; + is( '15959573e4a86763253a7aedb1a2b0c60d133dc2', hashsync( $mysync, q{} ), 'hashsync: + host2 zzz => ' ) ; + is( 'b8d4ab541b209c75928528020ca28ee43488bd8f', hashsync( $mysync, 'A' ), 'hashsync: + hashkey A => ' ) ; + + $mysync = undef ; + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hashsync( $mysync, q{} ), 'hashsync: undef $mysync' ) ; + $mysync->{ password1 } = 'abcd' ; + is( 'afa29ab8534495251ac8346a985717c54bc49c26', hashsync( $mysync, q{} ), 'hashsync: password1: abcd' ) ; + + # A user reported a massive failure on /X (Thomas V. 21/04/2020 à 21:41 Subject: Error) + # "Wide character in subroutine entry at /usr/local/lib/perl5/site_perl/Digest/HMAC.pm" + # I can reproduce it now + + + # The eval is there to avoid a complete crash + # this one is fatal so it is commented + # is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', 1 / 0 , 'hashsync: 1 / 0 fatal' ) ; + + my $eval ; + # this one is not fatal + is( undef, $eval = eval { 1 / 0 } , 'hashsync: 1/0 not fatal' ) ; + # this one neither + $mysync->{ password1 } = 'Ö' ; + is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', $eval = eval { hashsync( $mysync, q{} ) } , 'hashsync: password1: Ö with eval' ) ; + + $mysync->{ password1 } = 'Ö' ; + is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', hashsync( $mysync, q{} ), 'hashsync: password1: Ö without eval' ) ; + + $mysync->{ password1 } = qq{\x{00D6}} ; + is( 'bb5bfb461e79ecd3dbc6ade2aabb52d22fa8be1a', $eval = eval { hashsync( $mysync, q{} ) }, 'hashsync: password1: \x{00D6}' ) ; # + + print qq{1 00D6:Ö\n} ; + print encode_utf8( qq{2 00D6:Ö\n} ) ; + print qq{3 00D6:\x{00D6}\n} ; + print encode_utf8( qq{4 00D6:\x{00D6}\n} ) ; + + + print qq{5 6536:收\n} ; + print encode_utf8( qq{6 6536:收\n} ) ; + # the next one prints "Wide character in print at ./imapsync line xxxx" + print qq{7 6536:\x{6536}\n} ; + print encode_utf8( qq{8 6536:\x{6536}\n} ) ; + + $mysync->{ password1 } = qq{收} ; + is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hashsync( $mysync, q{} ), 'hashsync: password1: 收' ) ; + + $mysync->{ password1 } = qq{\x{6536}} ; + is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', $eval = eval{ hashsync( $mysync, q{} ) }, 'hashsync: password1: \x{6536} with eval' ) ; + + # No side effect. + $mysync->{ password1 } = 'abcd' ; + is( 'afa29ab8534495251ac8346a985717c54bc49c26', hashsync( $mysync, q{} ), 'hashsync: password1: abcd again' ) ; + + note( 'Leaving tests_hashsync()' ) ; + return ; +} + +sub hashsync +{ + my $mysync = shift @ARG ; + my $hashkey = shift @ARG ; + + my $mystring = join( q{}, + $mysync->{ host1 } || q{}, + $mysync->{ user1 } || q{}, + $mysync->{ password1 } || q{}, + $mysync->{ host2 } || q{}, + $mysync->{ user2 } || q{}, + $mysync->{ password2 } || q{}, + ) ; + #my $hashsync = hmac_sha1_hex( $mystring, $hashkey ) ; + my $hashsync = hmac_sha1_hex_robust( $mystring, $hashkey ) ; + #myprint( "$hashsync\n" ) ; + return( $hashsync ) ; +} + + +sub tests_hmac_sha1_hex +{ + note( 'Entering tests_hmac_sha1_hex()' ) ; + + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex( ), 'hmac_sha1_hex: no args => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ; + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex( '' ), 'hmac_sha1_hex: empty string => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ; + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex( '', '' ), 'hmac_sha1_hex: empty strings => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ; + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex( '', '', 'caca' ), 'hmac_sha1_hex: empty strings + caca => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ; + + # Good + is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', hmac_sha1_hex( 'Ö' ), 'hmac_sha1_hex: Ö => f1a3f3dac3f137fd658027c11678b895f773ce55' ) ; + is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', hmac_sha1_hex( encode_utf8(qq{\x{00D6}}) ), 'hmac_sha1_hex: encode_utf8 \x{00D6} => f1a3f3dac3f137fd658027c11678b895f773ce55' ) ; + # Bad + is( 'fe8dc3b9ba3e8850bb4a7b070b2279e911003af2', hmac_sha1_hex( encode_utf8( 'Ö' ) ), 'hmac_sha1_hex: encode_utf8 Ö => fe8dc3b9ba3e8850bb4a7b070b2279e911003af2' ) ; + is( 'bb5bfb461e79ecd3dbc6ade2aabb52d22fa8be1a', hmac_sha1_hex( qq{\x{00D6}} ), 'hmac_sha1_hex: qq{\x{00D6}} => bb5bfb461e79ecd3dbc6ade2aabb52d22fa8be1a' ) ; + + # Good + is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex( 'A' ), 'hmac_sha1_hex: A => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ; + is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex( encode_utf8(qq{\x{0041}}) ), 'hmac_sha1_hex: encode_utf8 \x{0041} => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ; + is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex( encode_utf8( 'A' ) ), 'hmac_sha1_hex: encode_utf8 A => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ; + is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex( qq{\x{0041}} ), 'hmac_sha1_hex: \x{0041} => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ; + + # Good + is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex( 'A', 'B' ), 'hmac_sha1_hex: A B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ; + is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex( encode_utf8(qq{\x{0041}}), 'B' ), 'hmac_sha1_hex: encode_utf8 \x{0041} B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ; + is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex( encode_utf8( 'A' ), 'B' ), 'hmac_sha1_hex: encode_utf8 A B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ; + is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex( qq{\x{0041}}, 'B' ), 'hmac_sha1_hex: \x{0041} B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ; + + # http://unicode.scarfboy.com/?s=U%2B6536 + # Good + is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex( '收' ), 'hmac_sha1_hex: 收 => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ; + is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex( encode_utf8(qq{\x{6536}}) ), 'hmac_sha1_hex: encode_utf8 \x{6536} => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ; + # Bad + is( 'e82217119628ad03e659cc89671d05ea4cee7238', hmac_sha1_hex( encode_utf8( '收' ) ), 'hmac_sha1_hex: encode_utf8 收 => e82217119628ad03e659cc89671d05ea4cee7238' ) ; + # Very very bad, perl dies... + #is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex( qq{\x{6536}} ), 'hmac_sha1_hex: \x{6536} => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ; + # Ok but well, bad indeed + is( undef, my $eval = eval{ hmac_sha1_hex( qq{\x{6536}} ) }, 'hmac_sha1_hex: \x{6536} => undef' ) ; + + + note( 'Leaving tests_hmac_sha1_hex()' ) ; + return ; +} + +sub tests_hmac_sha1_hex_robust +{ + note( 'Entering tests_hmac_sha1_hex_robust()' ) ; + + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex_robust( ), 'hmac_sha1_hex_robust: no args => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ; + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex_robust( '' ), 'hmac_sha1_hex_robust: empty string => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ; + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex_robust( '', '' ), 'hmac_sha1_hex_robust: empty strings => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ; + is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hmac_sha1_hex_robust( '', '', 'caca' ), 'hmac_sha1_hex_robust: empty strings + caca => fbdb1d1b18aa6c08324b7d64b71fb76370690e1d' ) ; + + # Good + is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', hmac_sha1_hex_robust( 'Ö' ), 'hmac_sha1_hex_robust: Ö => f1a3f3dac3f137fd658027c11678b895f773ce55' ) ; + is( 'f1a3f3dac3f137fd658027c11678b895f773ce55', hmac_sha1_hex_robust( encode_utf8(qq{\x{00D6}}) ), 'hmac_sha1_hex_robust: encode_utf8 \x{00D6} => f1a3f3dac3f137fd658027c11678b895f773ce55' ) ; + # Bad + is( 'fe8dc3b9ba3e8850bb4a7b070b2279e911003af2', hmac_sha1_hex_robust( encode_utf8( 'Ö' ) ), 'hmac_sha1_hex_robust: encode_utf8 Ö => fe8dc3b9ba3e8850bb4a7b070b2279e911003af2' ) ; + is( 'bb5bfb461e79ecd3dbc6ade2aabb52d22fa8be1a', hmac_sha1_hex_robust( qq{\x{00D6}} ), 'hmac_sha1_hex_robust: qq{\x{00D6}} => bb5bfb461e79ecd3dbc6ade2aabb52d22fa8be1a' ) ; + + # Good + is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex_robust( 'A' ), 'hmac_sha1_hex_robust: A => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ; + is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex_robust( encode_utf8(qq{\x{0041}}) ), 'hmac_sha1_hex_robust: encode_utf8 \x{0041} => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ; + is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex_robust( encode_utf8( 'A' ) ), 'hmac_sha1_hex_robust: encode_utf8 A => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ; + is( 'a6fda2a6acdd74630b20aac0c68716048ecd0333', hmac_sha1_hex_robust( qq{\x{0041}} ), 'hmac_sha1_hex_robust: \x{0041} => a6fda2a6acdd74630b20aac0c68716048ecd0333' ) ; + + # Good + is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex_robust( 'A', 'B' ), 'hmac_sha1_hex_robust: A B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ; + is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex_robust( encode_utf8(qq{\x{0041}}), 'B' ), 'hmac_sha1_hex_robust: encode_utf8 \x{0041} B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ; + is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex_robust( encode_utf8( 'A' ), 'B' ), 'hmac_sha1_hex_robust: encode_utf8 A B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ; + is( '36c54f255b575a2db58921d116b37c8af94c08cd', hmac_sha1_hex_robust( qq{\x{0041}}, 'B' ), 'hmac_sha1_hex_robust: \x{0041} B => 36c54f255b575a2db58921d116b37c8af94c08cd' ) ; + + # http://unicode.scarfboy.com/?s=U%2B6536 + # Good + is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex_robust( '收' ), 'hmac_sha1_hex_robust: 收 => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ; + is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex_robust( encode_utf8(qq{\x{6536}}) ), 'hmac_sha1_hex_robust: encode_utf8 \x{6536} => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ; + # Bad + is( 'e82217119628ad03e659cc89671d05ea4cee7238', hmac_sha1_hex_robust( encode_utf8( '收' ) ), 'hmac_sha1_hex_robust: encode_utf8 收 => e82217119628ad03e659cc89671d05ea4cee7238' ) ; + # Good + is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', hmac_sha1_hex_robust( qq{\x{6536}} ), 'hmac_sha1_hex_robust: \x{6536} => 4199f02773d1cd5599b1a8f2d024bdceb8b48e0b' ) ; + # Good again + is( '4199f02773d1cd5599b1a8f2d024bdceb8b48e0b', my $eval = eval{ hmac_sha1_hex_robust( qq{\x{6536}} ) }, 'hmac_sha1_hex_robust: \x{6536} => undef' ) ; + + note( 'Leaving tests_hmac_sha1_hex_robust()' ) ; + return ; +} + + +sub hmac_sha1_hex_robust +{ + my $string = shift @ARG ; + my $val ; + if ( defined( $val = eval{ hmac_sha1_hex( $string, @ARG ) } ) ) + { + return $val ; + } + elsif( defined( $val = eval{ hmac_sha1_hex( encode_utf8( $string ), @ARG ) } ) ) + { + return $val ; + } + else + { + return ; + } +} + +sub tests_createhashfileifneeded +{ + note( 'Entering tests_createhashfileifneeded()' ) ; + + is( undef, createhashfileifneeded( ), 'createhashfileifneeded: no parameters => undef' ) ; + + note( 'Leaving tests_createhashfileifneeded()' ) ; + return ; +} + +sub createhashfileifneeded +{ + my $hashfile = shift @ARG ; + my $hashkey = shift || rand32( ) ; + + # no name + if ( ! $hashfile ) { + return ; + } + # already there + if ( -e -r $hashfile ) { + return $hashfile ; + } + # not creatable + if ( ! -w dirname( $hashfile ) ) { + return ; + } + # creatable + open my $FILE_HANDLE, '>', $hashfile + or do { + myprint( "Could not open $hashfile for writing. Check permissions or disk space." ) ; + return ; + } ; + myprint( "Writing random hashkey in $hashfile, once for all times\n" ) ; + print $FILE_HANDLE $hashkey ; + close $FILE_HANDLE ; + # Should be there now + if ( -e -r $hashfile ) { + return $hashfile ; + } + # unknown failure + return ; +} + +sub tests_rand32 +{ + note( 'Entering tests_rand32()' ) ; + + my $string = rand32( ) ; + myprint( "$string\n" ) ; + is( 32, length( $string ), 'rand32: 32 characters long' ) ; + is( 32, length( rand32( ) ), 'rand32: 32 characters long, another one' ) ; + + note( 'Leaving tests_rand32()' ) ; + return ; +} + +sub rand32 +{ + my @chars = ( "a".."z" ) ; + my $string; + $string .= $chars[rand @chars] for 1..32 ; + return $string ; +} + +sub imap_id_stuff +{ + my $mysync = shift @ARG ; + + if ( not $mysync->{id} ) { return ; } ; + + $mysync->{h1_imap_id} = imap_id( $mysync, $mysync->{imap1}, 'Host1' ) ; + #myprint( 'Host1: ' . $mysync->{h1_imap_id} ) ; + $mysync->{h2_imap_id} = imap_id( $mysync, $mysync->{imap2}, 'Host2' ) ; + #myprint( 'Host2: ' . $mysync->{h2_imap_id} ) ; + + return ; +} + +sub imap_id +{ + my ( $mysync, $imap, $Side ) = @_ ; + + if ( not $mysync->{id} ) { return q{} ; } ; + + $Side ||= q{} ; + my $imap_id_response = q{} ; + + if ( not $imap->has_capability( 'ID' ) ) { + $imap_id_response = 'No ID capability' ; + myprint( "$Side: No ID capability\n" ) ; + }else{ + my $id_inp = imapsync_id( $mysync, { side => lc $Side } ) ; + myprint( "$Side: found ID capability. Sending/receiving ID, presented in raw IMAP for now.\n" + . "In order to avoid sending/receiving ID, use option --noid\n" ) ; + my $debug_before = $imap->Debug( ) ; + $imap->Debug( 1 ) ; + my $id_out = $imap->tag_and_run( 'ID ' . $id_inp ) ; + #my $id_out = $imap->tag_and_run( 'ID NIL' ) ; + #myprint( "\n" ) ; + $imap->Debug( $debug_before ) ; + #$imap_id_response = Data::Dumper->Dump( [ $id_out ], [ 'IMAP_ID' ] ) ; + } + return( $imap_id_response ) ; +} + +sub imapsync_id +{ + my $mysync = shift @ARG ; + my $overhashref = shift @ARG ; + # See http://tools.ietf.org/html/rfc2971.html + + my $imapsync_id = { } ; + + my $imapsync_id_lamiral = { + name => 'imapsync', + version => imapsync_version( $mysync ), + os => $OSNAME, + vendor => 'Gilles LAMIRAL', + 'support-url' => 'https://imapsync.lamiral.info/', + # Example of date-time: 19-Sep-2015 08:56:07 + date => date_from_rcs( q{$Date: 2022/09/14 18:08:24 $ } ), + } ; + + my $imapsync_id_github = { + name => 'imapsync', + version => imapsync_version( $mysync ), + os => $OSNAME, + vendor => 'github', + 'support-url' => 'https://github.com/imapsync/imapsync', + date => date_from_rcs( q{$Date: 2022/09/14 18:08:24 $ } ), + } ; + + $imapsync_id = $imapsync_id_lamiral ; + #$imapsync_id = $imapsync_id_github ; + my %mix = ( %{ $imapsync_id }, %{ $overhashref } ) ; + my $imapsync_id_str = format_for_imap_arg( \%mix ) ; + #myprint( "$imapsync_id_str\n" ) ; + return( $imapsync_id_str ) ; +} + +sub tests_imapsync_id +{ + note( 'Entering tests_imapsync_id()' ) ; + + my $mysync ; + ok( '("name" "imapsync" "version" "111" "os" "beurk" "vendor" "Gilles LAMIRAL" "support-url" "https://imapsync.lamiral.info/" "date" "22-12-1968" "side" "host1")' + eq imapsync_id( $mysync, + { + version => 111, + os => 'beurk', + date => '22-12-1968', + side => 'host1' + } + ), + 'tests_imapsync_id override' + ) ; + + note( 'Leaving tests_imapsync_id()' ) ; + return ; +} + +sub format_for_imap_arg +{ + my $ref = shift @ARG ; + + my $string = q{} ; + my %terms = %{ $ref } ; + my @terms = ( ) ; + if ( not ( %terms ) ) { return( 'NIL' ) } ; + # sort like in RFC then add extra key/values + foreach my $key ( qw( name version os os-version vendor support-url address date command arguments environment) ) { + if ( $terms{ $key } ) { + push @terms, $key, $terms{ $key } ; + delete $terms{ $key } ; + } + } + push @terms, %terms ; + $string = '(' . ( join q{ }, map { '"' . $_ . '"' } @terms ) . ')' ; + return( $string ) ; +} + + + +sub tests_format_for_imap_arg +{ + note( 'Entering tests_format_for_imap_arg()' ) ; + + ok( 'NIL' eq format_for_imap_arg( { } ), 'format_for_imap_arg empty hash ref' ) ; + ok( '("name" "toto")' eq format_for_imap_arg( { name => 'toto' } ), 'format_for_imap_arg { name => toto }' ) ; + ok( '("name" "toto" "key" "val")' eq format_for_imap_arg( { name => 'toto', key => 'val' } ), 'format_for_imap_arg 2 x key val' ) ; + + note( 'Leaving tests_format_for_imap_arg()' ) ; + return ; +} + +sub quota +{ + my ( $mysync, $imap, $side ) = @_ ; + + my %side = ( + h1 => 'Host1', + h2 => 'Host2', + ) ; + my $Side = $side{ $side } ; + my $debug_before = $imap->Debug( ) ; + $imap->Debug( 1 ) ; + if ( not $imap->has_capability( 'QUOTA' ) ) + { + myprint( "$Side: No QUOTA capability found, skipping it.\n" ) ; + $imap->Debug( $debug_before ) ; + return ; + } ; + myprint( "\n$Side: QUOTA capability found, presented in raw IMAP on next lines\n" ) ; + my $getquotaroot = $imap->getquotaroot( 'INBOX' ) ; + # Gmail INBOX quotaroot is "" but with it Mail::IMAPClient does a literal GETQUOTA {2} \n "" + #$imap->quota( 'ROOT' ) ; + #$imap->quota( '""' ) ; + myprint( "\n" ) ; + $imap->Debug( $debug_before ) ; + my $quota_limit_bytes = quota_extract_storage_limit_in_bytes( $mysync, $getquotaroot ) ; + my $quota_current_bytes = quota_extract_storage_current_in_bytes( $mysync, $getquotaroot ) ; + $mysync->{$side}->{quota_limit_bytes} = $quota_limit_bytes ; + $mysync->{$side}->{quota_current_bytes} = $quota_current_bytes ; + my $quota_percent ; + if ( $quota_limit_bytes > 0 ) { + $quota_percent = mysprintf( '%.2f', $NUMBER_100 * $quota_current_bytes / $quota_limit_bytes ) ; + }else{ + $quota_percent = 0 ; + } + myprint( "$Side: Quota current storage is $quota_current_bytes bytes. Limit is $quota_limit_bytes bytes. So $quota_percent % full\n" ) ; + if ( $QUOTA_PERCENT_LIMIT < $quota_percent ) { + my $error = "$Side: $quota_percent % full: it is time to find a bigger place! ( $quota_current_bytes bytes / $quota_limit_bytes bytes )\n" ; + errors_incr( $mysync, $error ) ; + } + return ; +} + +sub tests_quota_extract_storage_limit_in_bytes +{ + note( 'Entering tests_quota_extract_storage_limit_in_bytes()' ) ; + + my $mysync = {} ; + my $imap_output = [ + '* QUOTAROOT "INBOX" "Storage quota" "Messages quota"', + '* QUOTA "Storage quota" (STORAGE 1 104857600)', + '* QUOTA "Messages quota" (MESSAGE 2 100000)', + '5 OK Getquotaroot completed.' + ] ; + is( $NUMBER_104_857_600 * $KIBI, quota_extract_storage_limit_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_limit_in_bytes (STORAGE 1 104857600) => 104857600 * 1024') ; + $imap_output = [ + '* QUOTAROOT "INBOX" "Storage quota" "Messages quota"', + 'QUOTA "user-defined quota (konsoleH)" (STORAGE 988 48829 MESSAGE 20 20)', + '5 OK Getquotaroot completed.' + ] ; + is( 48829 * 1024, quota_extract_storage_limit_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_limit_in_bytes (STORAGE 988 48829 MESSAGE 20 20) => 48829 * 1024') ; + + note( 'Leaving tests_quota_extract_storage_limit_in_bytes()' ) ; + return ; +} + +sub quota_extract_storage_limit_in_bytes +{ + my $mysync = shift @ARG ; + my $imap_output = shift @ARG ; + + my $limit_kb ; + $limit_kb = ( map { /STORAGE\s+\d+\s+(\d+)/x ? $1 : () } @{ $imap_output } )[0] ; + $limit_kb ||= 0 ; + $mysync->{ debug } and myprint( "storage_limit_kb = $limit_kb\n" ) ; + return( $KIBI * $limit_kb ) ; +} + + +sub tests_quota_extract_storage_current_in_bytes +{ + note( 'Entering tests_quota_extract_storage_current_in_bytes()' ) ; + + my $mysync = {} ; + my $imap_output = [ + '* QUOTAROOT "INBOX" "Storage quota" "Messages quota"', + '* QUOTA "Storage quota" (STORAGE 1 104857600)', + '* QUOTA "Messages quota" (MESSAGE 2 100000)', + '5 OK Getquotaroot completed.' + ] ; + is( 1*$KIBI, quota_extract_storage_current_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_current_in_bytes: 1 => 1024 ') ; + + $imap_output = [ + '* QUOTAROOT "INBOX" "Storage quota" "Messages quota"', + 'QUOTA "user-defined quota (konsoleH)" (STORAGE 988 48829 MESSAGE 20 20)', + '5 OK Getquotaroot completed.' + ] ; + is( 988 * 1024, quota_extract_storage_current_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_current_in_bytes (STORAGE 988 48829 MESSAGE 20 20) => 988 * 1024') ; + + + note( 'Leaving tests_quota_extract_storage_current_in_bytes()' ) ; + return ; +} + +sub quota_extract_storage_current_in_bytes +{ + my $mysync = shift @ARG ; + my $imap_output = shift @ARG ; + + my $current_kb ; + $current_kb = ( map { /STORAGE\s+(\d+)\s+\d+/x ? $1 : () } @{ $imap_output } )[0] ; + $current_kb ||= 0 ; + $mysync->{ debug } and myprint( "storage_current_kb = $current_kb\n" ) ; + return( $KIBI * $current_kb ) ; + +} + + + +sub make_f1f2_array_to_a_hash +{ + my $mysync = shift @ARG ; + %{ $mysync->{ f1f2h } } = split_around_equal( @{ $mysync->{ f1f2 } } ) ; + + return ; +} + + + +sub automap +{ + my ( $mysync ) = @_ ; + + if ( $mysync->{automap} ) { + myprint( "Turned on automapping folders ( use --noautomap to turn off automapping )\n" ) ; + }else{ + myprint( "Turned off automapping folders ( use --automap to turn on automapping )\n" ) ; + return ; + } + + $mysync->{h1_special} = special_from_folders_hash( $mysync, $mysync->{imap1}, 'Host1' ) ; + $mysync->{h2_special} = special_from_folders_hash( $mysync, $mysync->{imap2}, 'Host2' ) ; + + build_possible_special( $mysync ) ; + build_guess_special( $mysync ) ; + build_automap( $mysync ) ; + + return ; +} + + + + +sub build_guess_special +{ + my ( $mysync ) = shift @ARG ; + + foreach my $h1_fold ( sort keys %{ $mysync->{h1_folders_all} } ) { + my $special = guess_special( $h1_fold, $mysync->{possible_special}, $mysync->{h1_prefix} ) ; + if ( $special ) { + $mysync->{h1_special_guessed}{$h1_fold} = $special ; + my $already_guessed = $mysync->{h1_special_guessed}{$special} ; + if ( $already_guessed ) { + myprint( "Host1: $h1_fold not $special because set to $already_guessed\n" ) ; + }else{ + $mysync->{h1_special_guessed}{$special} = $h1_fold ; + } + } + } + foreach my $h2_fold ( sort keys %{ $mysync->{h2_folders_all} } ) { + my $special = guess_special( $h2_fold, $mysync->{possible_special}, $mysync->{h2_prefix} ) ; + if ( $special ) { + $mysync->{h2_special_guessed}{$h2_fold} = $special ; + my $already_guessed = $mysync->{h2_special_guessed}{$special} ; + if ( $already_guessed ) { + myprint( "Host2: $h2_fold not $special because set to $already_guessed\n" ) ; + }else{ + $mysync->{h2_special_guessed}{$special} = $h2_fold ; + } + } + } + return ; +} + +sub guess_special +{ + my( $folder, $possible_special_ref, $prefix ) = @_ ; + + my $folder_no_prefix = $folder ; + $folder_no_prefix =~ s/\Q${prefix}\E//xms ; + #$debug and myprint( "folder_no_prefix: $folder_no_prefix\n" ) ; + + my $guess_special = $possible_special_ref->{ $folder } + || $possible_special_ref->{ $folder_no_prefix } + || q{} ; + + return( $guess_special ) ; +} + +sub tests_guess_special +{ + note( 'Entering tests_guess_special()' ) ; + + my $possible_special_ref = build_possible_special( my $mysync ) ; + ok( '\Sent' eq guess_special( 'Sent', $possible_special_ref, q{} ) ,'guess_special: Sent => \Sent' ) ; + ok( q{} eq guess_special( 'Blabla', $possible_special_ref, q{} ) ,'guess_special: Blabla => q{}' ) ; + ok( '\Sent' eq guess_special( 'INBOX.Sent', $possible_special_ref, 'INBOX.' ) ,'guess_special: INBOX.Sent => \Sent' ) ; + ok( '\Sent' eq guess_special( 'IN BOX.Sent', $possible_special_ref, 'IN BOX.' ) ,'guess_special: IN BOX.Sent => \Sent' ) ; + + note( 'Leaving tests_guess_special()' ) ; + return ; +} + +sub build_automap +{ + my $mysync = shift @ARG ; + $mysync->{ debug } and myprint( "Entering build_automap\n" ) ; + foreach my $h1_fold ( @{ $mysync->{h1_folders_wanted} } ) { + my $h2_fold ; + my $h1_special = $mysync->{h1_special}{$h1_fold} ; + my $h1_special_guessed = $mysync->{h1_special_guessed}{$h1_fold} ; + + # Case 1: special on both sides. + if ( $h1_special + and exists $mysync->{h2_special}{$h1_special} ) { + $h2_fold = $mysync->{h2_special}{$h1_special} ; + $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ; + next ; + } + # Case 2: special on host1, not on host2 + if ( $h1_special + and ( not exists $mysync->{h2_special}{$h1_special} ) + and ( exists $mysync->{h2_special_guessed}{$h1_special} ) + ) { + # special_guessed on host2 + $h2_fold = $mysync->{h2_special_guessed}{$h1_special} ; + $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ; + next ; + } + # Case 3: no special on host1, special on host2 + if ( ( not $h1_special ) + and ( $h1_special_guessed ) + and ( exists $mysync->{h2_special}{$h1_special_guessed} ) + ) { + $h2_fold = $mysync->{h2_special}{$h1_special_guessed} ; + $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ; + next ; + } + # Case 4: no special on both sides. + if ( ( not $h1_special ) + and ( $h1_special_guessed ) + and ( not exists $mysync->{h2_special}{$h1_special_guessed} ) + and ( exists $mysync->{h2_special_guessed}{$h1_special_guessed} ) + ) { + $h2_fold = $mysync->{h2_special_guessed}{$h1_special_guessed} ; + $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ; + next ; + } + } + return( $mysync->{f1f2auto} ) ; +} + +# I will not add what there is at: +# http://stackoverflow.com/questions/2185391/localized-gmail-imap-folders/2185548#2185548 +# because it works well without +sub build_possible_special +{ + my $mysync = shift @ARG ; + my $possible_special = { } ; + # All|Archive|Drafts|Flagged|Junk|Sent|Trash + + $possible_special->{'\All'} = [ 'All', 'All Messages', '&BBIEQQQ1-' ] ; + $possible_special->{'\Archive'} = [ 'Archive', 'Archives', '&BBAEQARFBDgEMg-' ] ; + $possible_special->{'\Drafts'} = [ 'Drafts', 'DRAFTS', '&BCcENQRABD0EPgQyBDgEOgQ4-', 'Szkice', 'Wersje robocze' ] ; + $possible_special->{'\Flagged'} = [ 'Flagged', 'Starred', '&BB8EPgQ8BDUERwQ1BD0EPQRLBDU-' ] ; + $possible_special->{'\Junk'} = [ 'Junk', 'junk', 'Spam', 'SPAM', '&BCEEPwQwBDw-', + 'Potwierdzony spam', 'Wiadomo&AVs-ci-&AVs-mieci', + 'Junk E-Mail', 'Junk Email'] ; + $possible_special->{'\Sent'} = [ 'Sent', 'Sent Messages', 'Sent Items', + 'Gesendete Elemente', 'Gesendete Objekte', + '&AMk-l&AOk-ments envoy&AOk-s', 'E&AwE-le&AwE-ments envoye&AwE-s', 'Envoy&AOk-', 'Objets envoy&AOk-s', + 'Elementos enviados', 'Posta inviata', + '&kAFP4W4IMH8wojCkMMYw4A-', + '&BB4EQgQ,BEAEMAQyBDsENQQ9BD0ESwQ1-', + 'Elementy wys&AUI-ane'] ; + $possible_special->{'\Trash'} = [ 'Trash', 'TRASH', + '&BCMENAQwBDsENQQ9BD0ESwQ1-', '&BBoEPgRABDcEOAQ9BDA-', + 'Kosz', + 'Deleted Items', 'Deleted Messages' ] ; + + + foreach my $special ( qw( \All \Archive \Drafts \Flagged \Junk \Sent \Trash ) ){ + foreach my $possible_folder ( @{ $possible_special->{$special} } ) { + $possible_special->{ $possible_folder } = $special ; + } ; + } + $mysync->{possible_special} = $possible_special ; + $mysync->{ debug } and myprint( Data::Dumper->Dump( [ $possible_special ], [ 'possible_special' ] ) ) ; + return( $possible_special ) ; +} + +sub tests_special_from_folders_hash +{ + note( 'Entering tests_special_from_folders_hash()' ) ; + + my $mysync = {} ; + require_ok( "Test::MockObject" ) ; + my $imapT = Test::MockObject->new( ) ; + + is( undef, special_from_folders_hash( ), 'special_from_folders_hash: no args' ) ; + is( undef, special_from_folders_hash( $mysync ), 'special_from_folders_hash: undef args' ) ; + is_deeply( {}, special_from_folders_hash( $mysync, $imapT ), 'special_from_folders_hash: $imap void' ) ; + + $imapT->mock( 'folders_hash', sub { return( [ { name => 'Sent', attrs => [ '\Sent' ] } ] ) } ) ; + + is_deeply( { Sent => '\Sent', '\Sent' => 'Sent' }, + special_from_folders_hash( $mysync, $imapT ), 'special_from_folders_hash: $imap \Sent' ) ; + + note( 'Leaving tests_special_from_folders_hash()' ) ; + return( ) ; +} + +sub special_from_folders_hash +{ + my ( $mysync, $imap, $side ) = @_ ; + my %special = ( ) ; + + if ( ! defined $imap ) { return ; } + $side = defined $side ? $side : 'Host?' ; + + if ( ! $imap->can( 'folders_hash' ) ) { + my $error = "$side: To have automagic rfc6154 folder mapping, upgrade Mail::IMAPClient >= 3.34\n" ; + errors_incr( $mysync, $error ) ; + return( \%special ) ; # empty hash ref + } + my $folders_hash = $imap->folders_hash( ) ; + foreach my $fhash (@{ $folders_hash } ) { + my @special = grep { /\\(?:All|Archive|Drafts|Flagged|Junk|Sent|Trash)/x } @{ $fhash->{attrs} } ; + if ( @special ) { + my $special = $special[0] ; # keep first one. Could be not very good. + if ( exists $special{ $special } ) { + myprintf( "%s: special %-20s = %s already assigned to %s\n", + $side, $fhash->{name}, join( q{ }, @special ), $special{ $special } ) ; + }else{ + myprintf( "%s: special %-20s = %s\n", + $side, $fhash->{name}, join( q{ }, @special ) ) ; + $special{ $special } = $fhash->{name} ; + $special{ $fhash->{name} } = $special ; # double entry value => key + } + } + } + myprint( "\n" ) if ( %special ) ; + return( \%special ) ; +} + + +sub tests_errors_log +{ + note( 'Entering tests_errors_log()' ) ; + is( undef, errors_log( ), 'errors_log: no args => undef' ) ; + my $mysync = {} ; + is( undef, errors_log( $mysync ), 'errors_log: empty => undef' ) ; + is_deeply( [ 'aieaie' ], [ errors_log( $mysync, 'aieaie' ) ], 'errors_log: aieaie => aieaie' ) ; + # cumulative + is_deeply( [ 'aieaie' ], [ errors_log( $mysync ) ], 'errors_log: nothing more => aieaie' ) ; + is_deeply( [ 'aieaie', 'ouille' ], [ errors_log( $mysync, 'ouille' ) ], 'errors_log: ouille => aieaie ouille' ) ; + is_deeply( [ 'aieaie', 'ouille' ], [ errors_log( $mysync ) ], 'errors_log: nothing more => aieaie ouille' ) ; + note( 'Leaving tests_errors_log()' ) ; + return ; +} + +sub errors_log +{ + my ( $mysync, @error ) = @ARG ; + + if ( ! $mysync->{errors_log} ) { + $mysync->{errors_log} = [] ; + } + + if ( @error ) { + push @{ $mysync->{errors_log} }, join( q{}, @error ) ; + } + if ( @{ $mysync->{errors_log} } ) { + return @{ $mysync->{errors_log} } ; + } + else { + return ; + } +} + + + +sub tests_comment_of_error_type +{ + note( 'Entering tests_comment_of_error_type()' ) ; + + is( undef, comment_of_error_type( ), 'comment_of_error_type: no args => undef' ) ; + + my $mysync = { } ; + is( undef, comment_of_error_type( $mysync ), 'comment_of_error_type: undef => undef' ) ; + + is( "", comment_of_error_type( $mysync, '' ), 'comment_of_error_type: "" => ""' ) ; + is( "", comment_of_error_type( $mysync, 'blabla' ), 'comment_of_error_type: blabla => ""' ) ; + + is( "", comment_of_error_type( $mysync, 'ERR_UNCLASSIFIED' ), 'comment_of_error_type: ERR_UNCLASSIFIED => ""' ) ; + + like( comment_of_error_type( $mysync, 'ERR_OVERQUOTA' ), qr{100% full}, 'comment_of_error_type: ERR_OVERQUOTA => matches 100% full' ) ; + + + + note( 'Leaving tests_comment_of_error_type()' ) ; + return ; +} + +sub comment_of_error_type +{ + my $mysync = shift @ARG ; + my $error_type = shift @ARG ; + + if ( ! defined $mysync ) { return ; } + if ( ! defined $error_type ) { return ; } + + my $comment ; + + if ( exists( $COMMENT_OF_ERR_TYPE{ $error_type } ) ) + { + $comment = $COMMENT_OF_ERR_TYPE{ $error_type }->( $mysync ) ; + } + else + { + $comment = "" ; + } + return $comment ; +} + + + +sub tests_error_type +{ + note( 'Entering tests_error_type()' ) ; + + is( 'ERR_NOTHING_REPORTED', error_type( ), 'error_type: no args => ERR_NOTHING_REPORTED' ) ; + is( 'ERR_NOTHING_REPORTED', error_type( '' ), 'error_type: empty string => ERR_NOTHING_REPORTED' ) ; + + is( 'ERR_UNCLASSIFIED', error_type( 'ERR_UNCLASSIFIED' ), 'error_type: ERR_UNCLASSIFIED => ERR_UNCLASSIFIED' ) ; + is( 'ERR_UNCLASSIFIED', error_type( 'aie' ), 'error_type: aie => ERR_UNCLASSIFIED' ) ; + is( 'ERR_UNCLASSIFIED', error_type( 'ouille' ), 'error_type: ouille => ERR_UNCLASSIFIED' ) ; + + is( 'ERR_Host1_FETCH', error_type( 'Message xxx could not be fetched: blabla' ), + 'error_type: could not be fetched => ERR_Host1_FETCH' + ) ; + + is( 'ERR_APPEND_SIZE', + error_type( 'could not append message xxx: BAD maximum message size exceeded' ), + 'error_type: could not append message xxx: BAD maximum message size exceeded => ERR_APPEND_SIZE' + ) ; + + is( 'ERR_OVERQUOTA', + error_type( 'Quota limit will be exceeded' ), + 'error_type: Quota limit will be exceeded => ERR_OVERQUOTA' + ) ; + + is( 'ERR_APPEND', error_type( 'could not append' ), 'error_type: could not append => ERR_APPEND' ) ; + + is( 'ERR_CREATE', + error_type( 'Could not create folder' ), + 'error_type: Could not create folder => ERR_CREATE' + ) ; + + is( 'ERR_SELECT', + error_type( 'Could not select: blabla' ), + 'error_type: Could not select: blabla => ERR_SELECT' + ) ; + + + # + #Maximum bytes transferred reached, 423 >= 100, ending sync + is( 'ERR_TRANSFER_EXCEEDED', + error_type( 'Maximum bytes transferred reached, blabla' ), + 'error_type: Maximum bytes transferred reached, blabla => ERR_TRANSFER_EXCEEDED' + ) ; + + # + is( 'ERR_CONNECTION_FAILURE_HOST1', + error_type( 'Host1 failure: can not open imap connection on host1 [badhostkaka] with user [tata]: Unable to connect to badhostkaka: Invalid argument' ), + 'error_type: can not open imap connection on host1 => ERR_CONNECTION_FAILURE_HOST1' + ) ; + + is( 'ERR_CONNECTION_FAILURE_HOST2', + error_type( 'Host2 failure: can not open imap connection on host2 [badhostkiki] with user [titi]: Unable to connect to badhostkiki: Invalid argument' ), + 'error_type: can not open imap connection on host2 => ERR_CONNECTION_FAILURE_HOST2' + ) ; + + is( 'ERR_APPEND_VIRUS', + error_type( 'could not append ( Subject:[For Your Consideration], Date:["29-Nov-2016 03:21:10 -0800"], Size:[5505], Flags:[\Seen] ) to folder INBOX: 275 NO Message refused because it contains a virus' ), + 'error_type: could not append ... virus => ERR_APPEND_VIRUS' + ) ; + + + is( 'ERR_FLAGS', + error_type( 'Host2: flags msg INBOX/957910 could not add flags [PasGlop \PasGlopRe]: 33 NO Error in IMAP command received by server.' ), + 'error_type: could not add flags => ERR_FLAGS' + ) ; + + + note( 'Leaving tests_error_type()' ) ; + return ; +} + + + +# Could be implemented with https://metacpan.org/pod/Tie::RegexpHash +# with just a hash of error regexes as keys and types as values. + +sub error_type +{ + my $error = shift @ARG ; + + if ( ! defined $error ) { return 'ERR_NOTHING_REPORTED' ; } + if ( ! $error ) { return 'ERR_NOTHING_REPORTED' ; } + + # + if ( $error =~ m{Host1 failure: Error login on} ) { return 'ERR_AUTHENTICATION_FAILURE_USER1' } ; + if ( $error =~ m{Host2 failure: Error login on} ) { return 'ERR_AUTHENTICATION_FAILURE_USER2' } ; + + if ( $error =~ m{Host. failure: Can not go to tls encryption on host.} ) { return 'ERR_EXIT_TLS_FAILURE' } ; + # + + if ( $error =~ m{could not be fetched:} ) { return 'ERR_Host1_FETCH' } ; + + # could not append .*BAD maximum message size exceeded + # could not append.*Maximum size of appendable message has been exceeded + if ( $error =~ m{could not append .*BAD maximum message size exceeded} ) + { return 'ERR_APPEND_SIZE' ; } ; + + if ( $error =~ m{could not append.*Maximum size of appendable message has been exceeded} ) + { return 'ERR_APPEND_SIZE' ; } ; + + # Could not create folder *[OVERQUOTA] Not enough disk quota + # could not append .*[OVERQUOTA] Not enough disk quota + # could not append .*[OVERQUOTA] Mailbox is full / Blocks limit exceeded / Inode limit exceeded + if ( $error =~ m{OVERQUOTA} ) { return 'ERR_OVERQUOTA' ; } ; + if ( $error =~ m{Quota limit will be exceeded} ) { return 'ERR_OVERQUOTA' ; } ; + if ( $error =~ m{full: it is time to find a bigger place} ) { return 'ERR_OVERQUOTA' ; } ; + + # could not append ... to folder INBOX: 276 NO Message refused because it contains a virus + if ( $error =~ m{could not append.*virus} ) + { return 'ERR_APPEND_VIRUS' ; } ; + + # could not append .*Write failed 'Broken pipe' + # could not append .*timeout waiting .* for data from server + # could not append .*BAD Invalid Arguments: Unable to parse message + # could not append .*BAD Command Argument Error. 11 + # could not append .*NO header limit reached + if ( $error =~ m{could not append} ) { return 'ERR_APPEND' ; } ; + + # could not add flags + if ( $error =~ m{could not add flags} ) { return 'ERR_FLAGS' ; } ; + + + # Could not create folder .*Invalid mailbox name + if ( $error =~ m{Could not create folder} ) { return 'ERR_CREATE' ; } ; + + + # Could not select:.*NO [NOPERM] Permission denied + # Could not select:.*NO Mailbox doesn't exist + # Could not select:.*NO [SERVERBUG] Internal error occurred. + # Could not select:.*[CANNOT] Mailbox isn't a valid mbox file + if ( $error =~ m{Could not select:} ) { return 'ERR_SELECT' ; } ; + + #Maximum bytes transferred reached, 423 >= 100, ending sync + if ( $error =~ m{Maximum bytes transferred reached} ) { return 'ERR_TRANSFER_EXCEEDED' ; } ; + + if ( $error =~ m{can not open imap connection on host1} ) { return 'ERR_CONNECTION_FAILURE_HOST1' ; } ; + if ( $error =~ m{can not open imap connection on host2} ) { return 'ERR_CONNECTION_FAILURE_HOST2' ; } ; + + # Default is ERR_UNCLASSIFIED + return 'ERR_UNCLASSIFIED' ; + +} + +sub tests_errorclassify +{ + note( 'Entering tests_errorclassify()' ) ; + + is( undef, errorclassify( ), 'errorclassify: no args => undef' ) ; + + is_deeply( { 'ERR_UNCLASSIFIED' => 1 }, errorclassify( 'aie' ), 'errorclassify: aie => { ERR_UNCLASSIFIED => 1 }' ) ; + is_deeply( { 'ERR_UNCLASSIFIED' => 2 }, errorclassify( 'aie', 'ouille' ), 'errorclassify: aie ouille => { ERR_UNCLASSIFIED => 2 }' ) ; + is_deeply( { 'ERR_UNCLASSIFIED' => 2, 'ERR_NOTHING_REPORTED' => 1 }, errorclassify( 'aie', 'ouille', '' ), 'errorclassify: aie ouille "" => { ERR_UNCLASSIFIED => 2 }' ) ; + is_deeply( { 'ERR_UNCLASSIFIED' => 3 }, errorclassify( 'aie', 'ouille', 'aie' ), 'errorclassify: aie ouille aie => { ERR_UNCLASSIFIED => 3 }' ) ; + is_deeply( { 'ERR_UNCLASSIFIED' => 1, 'ERR_OVERQUOTA' => 2 }, errorclassify( 'aie', 'OVERQUOTA pipi', 'OVERQUOTA caca' ), 'errorclassify: aie OVERQUOTA OVERQUOTA' ) ; + is_deeply( { 'ERR_NOTHING_REPORTED' => 1 }, errorclassify( '' ), 'errorclassify: "" => { ERR_NOTHING_REPORTED => 1 }' ) ; + is_deeply( { 'ERR_NOTHING_REPORTED' => 2 }, errorclassify( '', '' ), 'errorclassify: "", "" => { ERR_NOTHING_REPORTED => 1 }' ) ; + + note( 'Leaving tests_errorclassify()' ) ; + return ; +} + + + +sub errorclassify +{ + my @errors = @ARG ; + + if ( ! @errors ) { return ; } ; + + my $error_type_count = { } ; + foreach my $error ( @errors ) + { + my $error_type = error_type( $error ) ; + $error_type_count->{ $error_type }++ ; + } + + return $error_type_count ; +} + +sub tests_most_common_error +{ + note( 'Entering tests_most_common_error()' ) ; + + is( 'ERR_NOTHING_REPORTED', most_common_error( ), 'most_common_error: no args => ERR_NOTHING_REPORTED' ) ; + is( 'ERR_NOTHING_REPORTED', most_common_error( {} ), 'most_common_error: empty hash ref => ERR_NOTHING_REPORTED' ) ; + is( 'ERR_NOTHING_REPORTED', most_common_error( 'blabla' ), 'most_common_error: not a hash ref => ERR_NOTHING_REPORTED' ) ; + + is( 'ERR_FOO', most_common_error( { ERR_FOO => 1 } ), 'most_common_error: { ERR_FOO => 1 } => ERR_FOO' ) ; + is( 'ERR_BAR', most_common_error( { ERR_FOO => 1, ERR_BAR => 2 } ), 'most_common_error: { ERR_FOO => 1, ERR_BAR => 2 } => ERR_BAR' ) ; + is( 'ERR_FOO', most_common_error( { ERR_FOO => 2, ERR_BAR => 1 } ), 'most_common_error: { ERR_FOO => 2, ERR_BAR => 1 } => ERR_FOO' ) ; + # exaequo => first lexical wins. ERR_BAR <= ERR_FOO + is( 'ERR_BAR', most_common_error( { ERR_FOO => 2, ERR_BAR => 2 } ), 'most_common_error: { ERR_FOO => 2, ERR_BAR => 2 } => ERR_BAR' ) ; + + is( 'A', most_common_error( { A => 5, B => 5, C => 5 } ), 'most_common_error: { A => 5, B => 5, C => 5 } => A' ) ; + is( 'B', most_common_error( { A => 5, B => 6, C => 6 } ), 'most_common_error: { A => 5, B => 6, C => 6 } => B' ) ; + is( 'C', most_common_error( { A => 5, B => 5, C => 7 } ), 'most_common_error: { A => 5, B => 5, C => 7 } => C' ) ; + is( 'C', most_common_error( { A => 5, B => 6, C => 7 } ), 'most_common_error: { A => 5, B => 5, C => 7 } => C' ) ; + + note( 'Leaving tests_most_common_error()' ) ; + return ; +} + + + +sub most_common_error +{ + my $errors_counted_ref = shift @ARG ; + + if ( ! defined $errors_counted_ref ) { return 'ERR_NOTHING_REPORTED' ; } + + if ( 'HASH' ne ref $errors_counted_ref ) { return 'ERR_NOTHING_REPORTED' ; } + + # empty hash + if ( !%{ $errors_counted_ref } ) { return 'ERR_NOTHING_REPORTED' ; } + + # non empty hash + # in case of equality the winner error is the first in alphabetic order + my $most_common_error = ( sort + { + $errors_counted_ref->{$b} <=> $errors_counted_ref->{$a} + || $a cmp $b + } keys %{$errors_counted_ref} )[0] ; + + return $most_common_error ; + +} + + + +sub tests_errorsanalyse +{ + note( 'Entering tests_errorsanalyse()' ) ; + + is( 'ERR_NOTHING_REPORTED', errorsanalyse( ), 'errorsanalyse: no args => ERR_NOTHING_REPORTED' ) ; + is( 'ERR_NOTHING_REPORTED', errorsanalyse( ( ) ), 'errorsanalyse: empty list => ERR_NOTHING_REPORTED' ) ; + is( 'ERR_UNCLASSIFIED', errorsanalyse( 'aie' ), 'errorsanalyse: aie => ERR_UNCLASSIFIED' ) ; + + # in case of equality, empty wins + is( 'ERR_NOTHING_REPORTED', errorsanalyse( 'aie', '' ), 'errorsanalyse: aie => ERR_UNCLASSIFIED' ) ; + is( 'ERR_NOTHING_REPORTED', errorsanalyse( '', 'aie' ), 'errorsanalyse: aie => ERR_UNCLASSIFIED' ) ; + + + is( 'ERR_UNCLASSIFIED', errorsanalyse( 'aie', 'ouille' ), 'errorsanalyse: aie, ouille => ERR_UNCLASSIFIED' ) ; + is( 'ERR_UNCLASSIFIED', errorsanalyse( 'aie', 'ouille', '' ), 'errorsanalyse: aie, ouille, "" => ERR_UNCLASSIFIED' ) ; + is( 'ERR_UNCLASSIFIED', errorsanalyse( '', 'aie', 'ouille' ), 'errorsanalyse: aie, ouille, "" => ERR_UNCLASSIFIED' ) ; + + is( 'ERR_NOTHING_REPORTED', errorsanalyse( '' ), 'errorsanalyse: "" => ERR_NOTHING_REPORTED' ) ; + is( 'ERR_NOTHING_REPORTED', errorsanalyse( ( '' ) ), 'errorsanalyse: ( "" ) => ERR_NOTHING_REPORTED' ) ; + is( 'ERR_NOTHING_REPORTED', errorsanalyse( ( '', '' ) ), 'errorsanalyse: ( "", "" ) => ERR_NOTHING_REPORTED' ) ; + + note( 'Leaving tests_errorsanalyse()' ) ; + return ; +} + + + +sub errorsanalyse +{ + my @errors = @ARG ; + my $errors_types_counted = errorclassify( @errors ) ; + + my $most_common_error = most_common_error( $errors_types_counted ) ; + + return $most_common_error ; +} + + + +sub tests_errorsdump +{ + note( 'Entering tests_errorsdump()' ) ; + + is( undef, errorsdump( ), 'errorsdump: no args => undef' ) ; + is( undef, errorsdump( ( ) ), 'errorsdump: empty list => undef' ) ; + is( "Err 1/1: ", errorsdump( '' ), 'errorsdump: one empty string => "Err 1/1: "' ) ; + is( "Err 1/1: aieaieaie", errorsdump( 'aieaieaie' ), 'errorsdump: aieaieaie => "Err 1/1: aieaieaie"' ) ; + is( "Err 1/2: Aie Err 2/2: Ouille", errorsdump( 'Aie ', 'Ouille' ), 'errorsdump: Aie Ouille => "Err 1/2: Aie Err 2/2: Ouille"' ) ; + note( 'Leaving tests_errorsdump()' ) ; + return ; +} + + +sub errorsdump +{ + if ( ! @ARG ) { return ; } + + my @errors_log = @ARG ; + my $nb_errors = @errors_log ; + my $error_num = 0 ; + my $errors_list = q{} ; + if ( @errors_log ) { + foreach my $error ( @errors_log ) + { + $error_num++ ; + $errors_list .= "Err $error_num/$nb_errors: $error" ; + } + } + return( $errors_list ) ; +} + + + +sub errors_listing +{ + my $mysync = shift @ARG ; + $mysync->{ most_common_error } = errorsanalyse( errors_log( $mysync ) ) ; + + my $errors_listing = '' ; + + if ( $mysync->{ errorsdump } ) + { + $errors_listing = join( '', + "++++ Listing $mysync->{nb_errors} errors encountered during the sync ( avoid this listing with --noerrorsdump ).\n", + errorsdump( errors_log( $mysync ) ), + ) ; + } + + $errors_listing .= join( '', + "The most frequent error is $mysync->{ most_common_error }. ", + comment_of_error_type( $mysync, $mysync->{ most_common_error } ), + "\n", + ) ; + + return $errors_listing ; +} + + +sub errors_incr +{ + my ( $mysync, @error ) = @ARG ; + $mysync->{ nb_errors }++ ; + + if ( @error ) { + errors_log( $mysync, @error ) ; + myprint( @error ) ; + } + + $mysync->{ errorsmax } ||= $ERRORS_MAX ; + + + if ( $mysync->{ nb_errors } >= $mysync->{ errorsmax } ) + { + myprint( errorsmax_msg( $mysync ) ) ; + myprint( errors_listing( $mysync ) ) ; + + if ( $mysync->{ errorsdump } ) + { + # again since errorsdump( ) can be very verbose and masquerade previous warning + myprint( errorsmax_msg( $mysync ) ) ; + } + my $exit_value = exit_value( $mysync, $mysync->{ most_common_error } ) ; + exit_clean( $mysync, $exit_value ) ; + } + return ; +} + + + +sub errorsmax_msg +{ + my $mysync = shift @ARG ; + my $msg = "Maximum number of errors $mysync->{errorsmax} reached " + . "( you can change $mysync->{errorsmax} to any value, for example 100 with --errorsmax 100 ). " + . "Exiting.\n" ; + return $msg ; +} + + + + +sub tests_live_result +{ + note( 'Entering tests_live_result()' ) ; + + my $nb_errors = shift @ARG ; + if ( $nb_errors ) { + myprint( "Live tests failed with $nb_errors errors\n" ) ; + } else { + myprint( "Live tests ended successfully\n" ) ; + } + note( 'Leaving tests_live_result()' ) ; + return ; +} + + +sub size_filtered_flag +{ + my $mysync = shift @ARG ; + my $h1_size = shift @ARG ; + + if ( defined $mysync->{ maxsize } and $h1_size >= $mysync->{ maxsize } ) { + return( 1 ) ; + } + if ( defined $minsize and $h1_size <= $minsize ) { + return( 1 ) ; + } + return( 0 ) ; +} + +sub sync_flags_fir +{ + my ( $mysync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $h1_fir_ref, $h2_fir_ref ) = @_ ; + + if ( not defined $h1_msg ) { return } ; + if ( not defined $h2_msg ) { return } ; + + my $h1_size = $h1_fir_ref->{$h1_msg}->{'RFC822.SIZE'} ; + return if size_filtered_flag( $mysync, $h1_size ) ; + + # used cached flag values for efficiency + my $h1_flags = $h1_fir_ref->{ $h1_msg }->{ 'FLAGS' } || q{} ; + my $h2_flags = $h2_fir_ref->{ $h2_msg }->{ 'FLAGS' } || q{} ; + + sync_flags( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags ) ; + + return ; +} + +sub sync_flags_after_copy +{ + # Activated with option --syncflagsaftercopy + my( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg ) = @_ ; + + if ( my @h2_flags = $mysync->{imap2}->flags( $h2_msg ) ) { + my $h2_flags = "@h2_flags" ; + ( $mysync->{ debug } or $mysync->{ debugflags } ) and myprint( "Host2: msg $h2_fold/$h2_msg flags before sync flags after copy ( $h2_flags )\n" ) ; + sync_flags( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags ) ; + }else{ + myprint( "Host2: msg $h2_fold/$h2_msg could not get its flags for sync flags after copy\n" ) ; + } + return ; +} + + +sub sync_flags +{ + my( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags ) = @_ ; + + ( $mysync->{ debug } or $mysync->{ debugflags } ) and + myprint( "Host1: flags init msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 msg $h2_fold/$h2_msg flags( $h2_flags )\n" ) ; + + $h1_flags = flags_for_host2( $mysync, $h1_flags, $mysync->{ permanentflags2 } ) ; + + $h2_flags = flagscase( $h2_flags ) ; + + ( $mysync->{ debug } or $mysync->{ debugflags } ) and + myprint( "Host1: flags filt msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 msg $h2_fold/$h2_msg flags( $h2_flags )\n" ) ; + + + # compare flags - set flags if there a difference + my @h1_flags = sort split(q{ }, $h1_flags ); + my @h2_flags = sort split(q{ }, $h2_flags ); + my $diff = compare_lists( \@h1_flags, \@h2_flags ); + + $diff and ( $mysync->{ debug } or $mysync->{ debugflags } ) + and myprint( "Host2: flags msg $h2_fold/$h2_msg replacing h2 flags( $h2_flags ) with h1 flags( $h1_flags )\n" ) ; + + # This sets flags exactly. So flags can be removed with this. + # When you remove a \Seen flag on host1 you want it + # to be removed on host2. Just add flags is not what + # we need most of the time, so no + like in "+FLAGS.SILENT". + + if ( not $mysync->{ dry } and $diff and not $mysync->{ imap2 }->store( $h2_msg, "FLAGS.SILENT (@h1_flags)" ) ) { + my $error_msg = join q{}, "Host2: flags msg $h2_fold/$h2_msg could not add flags [@h1_flags]: ", + $mysync->{ imap2 }->LastError || q{}, "\n" ; + errors_incr( $mysync, $error_msg ) ; + } + + return ; +} + + + +sub _filter +{ + my $mysync = shift @ARG ; + my $str = shift or return q{} ; + my $sz = $SIZE_MAX_STR ; + my $len = length $str ; + if ( not $mysync->{ debug } and $len > $sz*2 ) { + my $beg = substr $str, 0, $sz ; + my $end = substr $str, -$sz, $sz ; + $str = $beg . '...' . $end ; + } + $str =~ s/\012?\015$//x ; + return "(len=$len) " . $str ; +} + + + +sub lost_connection +{ + my( $mysync, $imap, $error_message ) = @_; + if ( $imap->IsUnconnected( ) ) { + $mysync->{nb_errors}++ ; + my $lcomm = $imap->LastIMAPCommand || q{} ; + + my $einfo = imap_last_error( $imap ) ; + + # if string is long try reduce to a more reasonable size + $lcomm = _filter( $mysync, $lcomm ) ; + $einfo = _filter( $mysync, $einfo ) ; + myprint( "Failure: last command: $lcomm\n") if ( $mysync->{ debug } && $lcomm) ; + myprint( "Failure: lost connection $error_message: ", $einfo, "\n") ; + return( 1 ) ; + } + else{ + return( 0 ) ; + } +} + +sub imap_last_error +{ + my $imap = shift @ARG ; + my $einfo = $imap->LastError || @{$imap->History}[$LAST] || q{} ; + chomp( $einfo ) ; + return( $einfo ) ; +} + +sub tests_max +{ + note( 'Entering tests_max()' ) ; + + is( 0, max( 0 ), 'max 0 => 0' ) ; + is( 1, max( 1 ), 'max 1 => 1' ) ; + is( $MINUS_ONE, max( $MINUS_ONE ), 'max -1 => -1') ; + is( undef, max( ), 'max no arg => undef' ) ; + is( undef, max( undef ), 'undef => undef' ) ; + is( undef, max( undef, undef ), 'undef, undef => undef' ) ; + + is( $NUMBER_100, max( 1, $NUMBER_100 ), 'max 1 100 => 100' ) ; + is( $NUMBER_100, max( $NUMBER_100, 1 ), 'max 100 1 => 100' ) ; + is( $NUMBER_100, max( $NUMBER_100, $NUMBER_42, 1 ), 'max 100 42 1 => 100' ) ; + is( $NUMBER_100, max( $NUMBER_100, '42', 1 ), 'max 100 42 1 => 100' ) ; + is( $NUMBER_100, max( '100', '42', 1 ), 'max 100 42 1 => 100' ) ; + is( $NUMBER_100, max( $NUMBER_100, 'haha', 1 ), 'max 100 haha 1 => 100') ; + is( $NUMBER_100, max( 'bb', $NUMBER_100, 'haha' ), 'max bb 100 haha => 100') ; + is( $MINUS_ONE, max( q{}, $MINUS_ONE, 'haha' ), 'max "" -1 haha => -1') ; + is( $MINUS_ONE, max( q{}, $MINUS_ONE, $MINUS_TWO ), 'max "" -1 -2 => -1') ; + is( $MINUS_ONE, max( 'haha', $MINUS_ONE, $MINUS_TWO ), 'max haha -1 -2 => -1') ; + is( 1, max( $MINUS_ONE, 1 ), 'max -1 1 => 1') ; + is( 1, max( undef, 1 ), 'max undef 1 => 1' ) ; + is( 0, max( undef, 0 ), 'max undef 0 => 0' ) ; + is( 'haha', max( 'haha' ), 'max haha => haha') ; + is( 'bb', max( 'aa', 'bb' ), 'max aa bb => bb') ; + is( 'bb', max( 'bb', 'aa' ), 'max bb aa => bb') ; + is( 'bb', max( 'bb', 'aa', 'bb' ), 'max bb aa bb => bb') ; + note( 'Leaving tests_max()' ) ; + return ; +} + +sub max +{ + my @list = @_ ; + return( undef ) if ( 0 == scalar @list ) ; + + my( @numbers, @notnumbers ) ; + foreach my $item ( @list ) + { + if ( is_number( $item ) ) + { + push @numbers, $item ; + } + elsif ( defined $item ) + { + push @notnumbers, $item ; + } + } + + my @sorted ; + + if ( @numbers ) + { + @sorted = sort { $a <=> $b } @numbers ; + } + elsif ( @notnumbers ) + { + @sorted = sort { $a cmp $b } @notnumbers ; + } + else + { + return ; + } + + return( pop @sorted ) ; +} + +sub tests_is_number +{ + note( 'Entering tests_is_number()' ) ; + + is( undef, is_number( ), 'is_number: no args => undef ' ) ; + is( undef, is_number( undef ), 'is_number: undef => undef ' ) ; + ok( is_number( 1 ), 'is_number: 1 => 1' ) ; + ok( is_number( 1.1 ), 'is_number: 1.1 => 1' ) ; + ok( is_number( 0 ), 'is_number: 0 => 1' ) ; + ok( is_number( -1 ), 'is_number: -1 => 1' ) ; + ok( ! is_number( 1.1.1 ), 'is_number: 1.1.1 => no' ) ; + ok( ! is_number( q{} ), 'is_number: q{} => no' ) ; + ok( ! is_number( 'haha' ), 'is_number: haha => no' ) ; + ok( ! is_number( '0haha' ), 'is_number: 0haha => no' ) ; + ok( ! is_number( '2haha' ), 'is_number: 2haha => no' ) ; + ok( ! is_number( 'haha2' ), 'is_number: haha2 => no' ) ; + + note( 'Leaving tests_is_number()' ) ; + return ; +} + + + +sub is_number +{ + my $item = shift @ARG ; + + if ( ! defined $item ) { return ; } + + if ( $item =~ /\A$RE{num}{real}\Z/ ) { + return 1 ; + } + return ; +} + +sub tests_min +{ + note( 'Entering tests_min()' ) ; + + is( 0, min( 0 ), 'min 0 => 0' ) ; + is( 1, min( 1 ), 'min 1 => 1' ) ; + is( $MINUS_ONE, min( $MINUS_ONE ), 'min -1 => -1' ) ; + is( undef, min( ), 'min no arg => undef' ) ; + is( 1, min( 1, $NUMBER_100 ), 'min 1 100 => 1' ) ; + is( 1, min( $NUMBER_100, 1 ), 'min 100 1 => 1' ) ; + is( 1, min( $NUMBER_100, $NUMBER_42, 1 ), 'min 100 42 1 => 1' ) ; + is( 1, min( $NUMBER_100, '42', 1 ), 'min 100 42 1 => 1' ) ; + is( 1, min( '100', '42', 1 ), 'min 100 42 1 => 1' ) ; + is( 1, min( $NUMBER_100, 'haha', 1 ), 'min 100 haha 1 => 1') ; + is( $MINUS_ONE, min( $MINUS_ONE, 1 ), 'min -1 1 => -1') ; + + is( 1, min( undef, 1 ), 'min undef 1 => 1' ) ; + is( 0, min( undef, 0 ), 'min undef 0 => 0' ) ; + is( 1, min( undef, 1 ), 'min undef 1 => 1' ) ; + is( 0, min( undef, 2, 0, 1 ), 'min undef, 2, 0, 1 => 0' ) ; + + is( 'haha', min( 'haha' ), 'min haha => haha') ; + is( 'aa', min( 'aa', 'bb' ), 'min aa bb => aa') ; + is( 'aa', min( 'bb', 'aa' ), 'min bb aa bb => aa') ; + is( 'aa', min( 'bb', 'aa', 'bb' ), 'min bb aa bb => aa') ; + + note( 'Leaving tests_min()' ) ; + return ; +} + + +sub min +{ + my @list = @_ ; + return( undef ) if ( 0 == scalar @list ) ; + + my( @numbers, @notnumbers ) ; + foreach my $item ( @list ) { + if ( is_number( $item ) ) { + push @numbers, $item ; + }else{ + push @notnumbers, $item ; + } + } + + my @sorted ; + if ( @numbers ) { + @sorted = sort { $a <=> $b } @numbers ; + }elsif( @notnumbers ) { + @sorted = sort { $a cmp $b } @notnumbers ; + }else{ + return ; + } + + return( shift @sorted ) ; +} + + +sub check_lib_version +{ + my $mysync = shift @ARG ; + $mysync->{ debug } and myprint( "IMAPClient $Mail::IMAPClient::VERSION\n" ) ; + if ( '2.2.9' eq $Mail::IMAPClient::VERSION ) { + myprint( "imapsync no longer supports Mail::IMAPClient 2.2.9, upgrade it\n" ) ; + return 0 ; + } + else{ + # 3.x.x is no longer buggy with imapsync. + # 3.30 or currently superior is imposed in the Perl "use Mail::IMAPClient line". + return 1 ; + } + return ; +} + +sub module_version_str +{ + my( $module_name, $module_version ) = @_ ; + my $str = mysprintf( "%-20s %s\n", $module_name, $module_version ) ; + return( $str ) ; +} + +sub modulesversion +{ + + my @list_version; + + my %modulesversion = ( + 'Authen::NTLM' => sub { $Authen::NTLM::VERSION }, + 'CGI' => sub { $CGI::VERSION }, + 'Compress::Zlib' => sub { $Compress::Zlib::VERSION }, + 'Crypt::OpenSSL::RSA' => sub { $Crypt::OpenSSL::RSA::VERSION }, + 'Data::Uniqid' => sub { $Data::Uniqid::VERSION }, + 'Digest::HMAC_MD5' => sub { $Digest::HMAC_MD5::VERSION }, + 'Digest::HMAC_SHA1' => sub { $Digest::HMAC_SHA1::VERSION }, + 'Digest::MD5' => sub { $Digest::MD5::VERSION }, + 'Encode' => sub { $Encode::VERSION }, + 'Encode::IMAPUTF7' => sub { $Encode::IMAPUTF7::VERSION }, + 'File::Copy::Recursive' => sub { $File::Copy::Recursive::VERSION }, + 'File::Spec' => sub { $File::Spec::VERSION }, + 'Getopt::Long' => sub { $Getopt::Long::VERSION }, + 'HTML::Entities' => sub { $HTML::Entities::VERSION }, + 'IO::Socket' => sub { $IO::Socket::VERSION }, + 'IO::Socket::INET' => sub { $IO::Socket::INET::VERSION }, + 'IO::Socket::INET6' => sub { $IO::Socket::INET6::VERSION }, + 'IO::Socket::IP' => sub { $IO::Socket::IP::VERSION }, + 'IO::Socket::SSL' => sub { $IO::Socket::SSL::VERSION }, + 'IO::Tee' => sub { $IO::Tee::VERSION }, + 'JSON' => sub { $JSON::VERSION }, + 'JSON::WebToken' => sub { $JSON::WebToken::VERSION }, + 'LWP' => sub { $LWP::VERSION }, + 'Mail::IMAPClient' => sub { $Mail::IMAPClient::VERSION }, + 'MIME::Base64' => sub { $MIME::Base64::VERSION }, + 'Net::Ping' => sub { $Net::Ping::VERSION }, + 'Net::SSLeay' => sub { $Net::SSLeay::VERSION }, + 'Term::ReadKey' => sub { $Term::ReadKey::VERSION }, + 'Test::MockObject' => sub { $Test::MockObject::VERSION }, + 'Time::HiRes' => sub { $Time::HiRes::VERSION }, + 'Unicode::String' => sub { $Unicode::String::VERSION }, + 'URI::Escape' => sub { $URI::Escape::VERSION }, + #'Lalala' => sub { $Lalala::VERSION }, + ) ; + + foreach my $module_name ( sort keys %modulesversion ) { + # trick from http://www.perlmonks.org/?node_id=152122 + my $file_name = $module_name . '.pm' ; + $file_name =~s,::,/,xmgs; # Foo::Bar::Baz => Foo/Bar/Baz.pm + my $v ; + eval { + require $file_name ; + $v = defined $modulesversion{ $module_name } ? $modulesversion{ $module_name }->() : q{?} ; + } or $v = q{Not installed} ; + + push @list_version, module_version_str( $module_name, $v ) ; + } + return( @list_version ) ; +} + + +sub tests_command_line_nopassword +{ + note( 'Entering tests_command_line_nopassword()' ) ; + + ok( q{} eq command_line_nopassword(), 'command_line_nopassword void' ); + my $mysync = {} ; + ok( '--blabla' eq command_line_nopassword( $mysync, '--blabla' ), 'command_line_nopassword --blabla' ); + #myprint( command_line_nopassword((qw{ --password1 secret1 })), "\n" ) ; + ok( '--password1 MASKED' eq command_line_nopassword( $mysync, qw{ --password1 secret1}), 'command_line_nopassword --password1' ); + ok( '--blabla --password1 MASKED --blibli' + eq command_line_nopassword( $mysync, qw{ --blabla --password1 secret1 --blibli } ), 'command_line_nopassword --password1 --blibli' ); + $mysync->{showpasswords} = 1 ; + ok( q{} eq command_line_nopassword(), 'command_line_nopassword void' ); + ok( '--blabla' eq command_line_nopassword( $mysync, '--blabla'), 'command_line_nopassword --blabla' ); + #myprint( command_line_nopassword((qw{ --password1 secret1 })), "\n" ) ; + ok( '--password1 secret1' eq command_line_nopassword( $mysync, qw{ --password1 secret1} ), 'command_line_nopassword --password1' ); + ok( '--blabla --password1 secret1 --blibli' + eq command_line_nopassword( $mysync, qw{ --blabla --password1 secret1 --blibli } ), 'command_line_nopassword --password1 --blibli' ); + + note( 'Leaving tests_command_line_nopassword()' ) ; + return ; +} + +# Construct a command line copy with passwords replaced by MASKED. +sub command_line_nopassword +{ + my $mysync = shift @ARG ; + my @argv = @ARG ; + my @argv_nopassword ; + + if ( $mysync->{ cmdcgi } ) { + @argv_nopassword = mask_password_value( @{ $mysync->{ cmdcgi } } ) ; + return( "@argv_nopassword" ) ; + } + + if ( $mysync->{showpasswords} ) + { + return( "@argv" ) ; + } + + @argv_nopassword = mask_password_value( @argv ) ; + return("@argv_nopassword") ; +} + +sub mask_password_value +{ + my @argv = @ARG ; + my @argv_nopassword ; + while ( @argv ) { + my $arg = shift @argv ; # option name or value + if ( $arg =~ m/-password[12]/x ) { + shift @argv ; # password value + push @argv_nopassword, $arg, 'MASKED' ; # option name and fake value + }else{ + push @argv_nopassword, $arg ; # same option or value + } + } + return @argv_nopassword ; +} + + +sub tests_get_stdin_masked +{ + note( 'Entering tests_get_stdin_masked()' ) ; + + is( q{}, get_stdin_masked( ), 'get_stdin_masked: no args' ) ; + is( q{}, get_stdin_masked( 'Please ENTER: ' ), 'get_stdin_masked: ENTER' ) ; + + note( 'Leaving tests_get_stdin_masked()' ) ; + return ; +} + +####################################################### +# The issue is that prompt() does not prompt the prompt +# when the program is used like +# { sleep 2 ; echo blablabla ; } | ./imapsync ...--host1 lo --user1 tata --host2 lo --user2 titi + +# use IO::Prompter ; +sub get_stdin_masked +{ + my $prompt = shift || 'Say something: ' ; + local @ARGV = () ; + my $input = prompt( + -prompt => $prompt, + -echo => '*', + ) ; + #myprint( "You said: $input\n" ) ; + return $input ; +} + +sub ask_for_password_new +{ + my $prompt = shift @ARG ; + my $password = get_stdin_masked( $prompt ) ; + return $password ; +} +######################################################### + + +sub ask_for_password +{ + my $prompt = shift @ARG ; + myprint( $prompt ) ; + Term::ReadKey::ReadMode( 2 ) ; + ## no critic (InputOutput::ProhibitExplicitStdin) + my $password = ; + chomp $password ; + myprint( "\nGot it\n" ) ; + Term::ReadKey::ReadMode( 0 ) ; + return $password ; +} + +# Have to refactor get_password1() get_password2() +# to have only get_password() and two calls +sub get_password1 +{ + + my $mysync = shift @ARG ; + + $mysync->{ password1 } + || $mysync->{ passfile1 } + || 'PREAUTH' eq $mysync->{ acc1 }->{ authmech } + || 'EXTERNAL' eq $mysync->{ acc1 }->{ authmech } + || $ENV{IMAPSYNC_PASSWORD1} + || do + { + myprint( << 'FIN_PASSFILE' ) ; + +If you are afraid of giving password on the command line arguments, you can put the +password of user1 in a file named file1 and use "--passfile1 file1" instead of typing it. +Then give this file restrictive permissions with the command "chmod 600 file1". +An other solution is to set the environment variable IMAPSYNC_PASSWORD1 +FIN_PASSFILE + my $user = $mysync->{ acc1 }->{ authuser } || $mysync->{ user1 } ; + my $host = $mysync->{ host1 } ; + my $prompt = "What's the password for $user" . ' at ' . "$host? (not visible while you type, then enter RETURN) " ; + $mysync->{password1} = ask_for_password( $prompt ) ; + } ; + + if ( defined $mysync->{ passfile1 } ) { + if ( ! -e -r $mysync->{ passfile1 } ) { + myprint( "Failure: file from parameter --passfile1 $mysync->{ passfile1 } does not exist or is not readable\n" ) ; + $mysync->{nb_errors}++ ; + exit_clean( $mysync, $EX_NOINPUT ) ; + } + # passfile1 readable + $mysync->{password1} = firstline ( $mysync->{ passfile1 } ) ; + return ; + } + if ( $ENV{IMAPSYNC_PASSWORD1} ) { + $mysync->{password1} = $ENV{IMAPSYNC_PASSWORD1} ; + return ; + } + return ; +} + +sub get_password2 +{ + + my $mysync = shift @ARG ; + + $mysync->{password2} + || $mysync->{ passfile2 } + || 'PREAUTH' eq $mysync->{ acc2 }->{ authmech } + || 'EXTERNAL' eq $mysync->{ acc2 }->{ authmech } + || $ENV{IMAPSYNC_PASSWORD2} + || do + { + myprint( << 'FIN_PASSFILE' ) ; + +If you are afraid of giving password on the command line arguments, you can put the +password of user2 in a file named file2 and use "--passfile2 file2" instead of typing it. +Then give this file restrictive permissions with the command "chmod 600 file2". +An other solution is to set the environment variable IMAPSYNC_PASSWORD2 +FIN_PASSFILE + my $user = $mysync->{ acc2 }->{ authuser } || $mysync->{ user2 } ; + my $host = $mysync->{ host2 } ; + my $prompt = "What's the password for $user" . ' at ' . "$host? (not visible while you type, then enter RETURN) " ; + $mysync->{password2} = ask_for_password( $prompt ) ; + } ; + + + if ( defined $mysync->{ passfile2 } ) { + if ( ! -e -r $mysync->{ passfile2 } ) { + myprint( "Failure: file from parameter --passfile2 $mysync->{ passfile2 } does not exist or is not readable\n" ) ; + $mysync->{nb_errors}++ ; + exit_clean( $mysync, $EX_NOINPUT ) ; + } + # passfile2 readable + $mysync->{password2} = firstline ( $mysync->{ passfile2 } ) ; + return ; + } + if ( $ENV{IMAPSYNC_PASSWORD2} ) { + $mysync->{password2} = $ENV{IMAPSYNC_PASSWORD2} ; + return ; + } + return ; +} + + + + +sub remove_tmp_files +{ + my $mysync = shift or return ; + $mysync->{pidfile} or return ; + + if ( -e $mysync->{pidfile} ) { + myprint( "Removing pidfile $mysync->{pidfile}\n" ) ; + unlink $mysync->{pidfile} ; + } + if ( -e $mysync->{abortfile} ) { + myprint( "Removing pidfile $mysync->{abortfile}\n" ) ; + unlink $mysync->{abortfile} ; + } + return ; +} + +sub cleanup_before_exit +{ + my $mysync = shift @ARG ; + + remove_tmp_files( $mysync ) ; + + if ( $mysync->{ imap1 } and $mysync->{ imap1 }->IsConnected() ) + { + myprint( "Disconnecting from host1 $mysync->{ host1 } user1 $mysync->{ user1 }\n" ) ; + $mysync->{ imap1 }->logout( ) ; + } + + if ( $mysync->{ imap2 } and $mysync->{ imap2 }->IsConnected() ) + { + myprint( "Disconnecting from host2 $mysync->{ host2 } user2 $mysync->{ user2 }\n" ) ; + $mysync->{ imap2 }->logout( ) ; + } + + if ( $mysync->{ log } ) { + myprint( "Log file is $mysync->{logfile} ( to change it, use --logfile filepath ; or use --nolog to turn off logging )\n" ) ; + } + else + { + myprint( "No log file because of option --nolog\n" ) ; + } + + if ( $mysync->{ log } ) { + #print( "Closing $mysync->{ logfile }\n" ) ; + teefinish( $mysync->{ tee } ) ; + } + $IO::Socket::SSL::DEBUG = 1 ; + return ; +} + + +sub tests_exit_value +{ + note( 'Entering tests_exit_value()' ) ; + + is( $EXIT_CATCH_ALL, exit_value( ), 'exit_value: no args => EXIT_CATCH_ALL' ) ; + + my $mysync = { } ; + is( $EXIT_CATCH_ALL, exit_value( $mysync ), 'exit_value: undef => EXIT_CATCH_ALL' ) ; + + is( $EXIT_CATCH_ALL, exit_value( $mysync, 'Blabla_unknown' ), 'exit_value: Blabla => EXIT_CATCH_ALL' ) ; + is( $EXIT_CATCH_ALL, exit_value( $mysync, '' ), 'exit_value: empty => EXIT_CATCH_ALL' ) ; + + + is( $EXIT_OVERQUOTA, exit_value( $mysync, 'ERR_OVERQUOTA' ), 'exit_value: ERR_OVERQUOTA => EXIT_OVERQUOTA' ) ; + is( $EXIT_TRANSFER_EXCEEDED, exit_value( $mysync, 'ERR_TRANSFER_EXCEEDED' ), 'exit_value: ERR_TRANSFER_EXCEEDED => EXIT_TRANSFER_EXCEEDED' ) ; + + note( 'Leaving tests_exit_value()' ) ; + return ; +} + +sub exit_value +{ + my $mysync = shift @ARG ; + my $most_common_error = shift @ARG ; + + if ( ! defined $most_common_error ) { return $EXIT_CATCH_ALL ; } + my $exit_value = $EXIT_VALUE_OF_ERR_TYPE{ $most_common_error } || $EXIT_CATCH_ALL ; + + return $exit_value ; +} + + + +sub exit_most_errors +{ + my $mysync = shift @ARG ; + + myprint( errors_listing( $mysync ) ) ; + my $exit_value = exit_value( $mysync, $mysync->{ most_common_error } ) ; + exit_clean( $mysync, $exit_value ) ; + return ; +} + +sub exit_clean +{ + my $mysync = shift @ARG ; + my $status = shift @ARG ; + my @messages = @ARG ; + if ( @messages ) + { + myprint( @messages ) ; + } + myprint( "Exiting with return value $status ($EXIT_TXT{$status}) $mysync->{nb_errors}/$mysync->{errorsmax} nb_errors/max_errors PID $PROCESS_ID\n" ) ; + cleanup_before_exit( $mysync ) ; + + exit $status ; +} + +sub missing_option +{ + my $mysync = shift @ARG ; + my $option = shift @ARG ; + $mysync->{nb_errors}++ ; + exit_clean( $mysync, $EX_USAGE, "$option option is mandatory, for help run $PROGRAM_NAME --help\n" ) ; + return ; +} + + +sub catch_ignore +{ + my $mysync = shift @ARG ; + my $signame = shift @ARG ; + + my $sigcounter = ++$mysync->{ sigcounter }{ $signame } ; + myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", mygetppid( ), + "). Received $sigcounter $signame signals so far. Thanks!\n" ) ; + do_and_print_stats( $mysync ) ; + return ; +} + + + +sub catch_exit +{ + my $mysync = shift @ARG ; + my $signame = shift || q{} ; + if ( $signame ) { + myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", mygetppid( ), + "). Asked to terminate\n" ) ; + if ( $mysync->{can_do_stats} ) { + do_and_print_stats( $mysync ) ; + myprint( "Ended by a signal $signame (my PID is $PROCESS_ID my PPID is ", + mygetppid( ), "). I am asked to terminate immediately.\n" ) ; + } + myprint( "You should resynchronize those accounts by running a sync again,\n", + "since some messages and entire folders might still be missing on host2.\n" + ) ; + ## no critic (RequireLocalizedPunctuationVars) + # Well, restore default action does not work well + $SIG{ $signame } = 'DEFAULT'; # restore default action + #$SIG{ 'TERM' } = 'DEFAULT'; # restore default action + # kill myself with $signame + # https://www.cons.org/cracauer/sigint.html + myprint( "Killing myself with signal $signame\n" ) ; + #cleanup_before_exit( $mysync ) ; + kill( $signame, $PROCESS_ID ) ; + #kill( 'TERM', $PROCESS_ID ) ; + #sleep 1 ; + #while ( 1 ) { } ; + $mysync->{nb_errors}++ ; + exit_clean( $mysync, $EXIT_BY_SIGNAL, + "Still there after killing myself with signal $signame...\n" + ) ; + } + else + { + $mysync->{nb_errors}++ ; + exit_clean( $mysync, $EXIT_BY_SIGNAL, "Exiting in catch_exit with no signal...\n" ) ; + } + return ; +} + + +sub catch_print +{ + my $mysync = shift @ARG ; + my $signame = shift @ARG ; + + my $sigcounter = ++$mysync->{ sigcounter }{ $signame } ; + myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", mygetppid( ), + "). Received $sigcounter $signame signals so far. Thanks!\n" ) ; + return ; +} + +sub here_twice +{ + my $mysync = shift @ARG ; + my $now = time ; + my $previous = $mysync->{lastcatch} || 0 ; + $mysync->{lastcatch} = $now ; + + if ( $INTERVAL_TO_EXIT >= $now - $previous ) { + return $TRUE ; + }else{ + return $FALSE ; + } +} + + +sub catch_reconnect +{ + my $mysync = shift @ARG ; + my $signame = shift @ARG ; + if ( here_twice( $mysync ) ) { + myprint( "Got two signals $signame within $INTERVAL_TO_EXIT seconds. Exiting...\n" ) ; + catch_exit( $mysync, $signame ) ; + }else{ + myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", mygetppid( ), ")\n", + "Hit 2 ctr-c within 2 seconds to exit the program\n", + "Hit only 1 ctr-c to reconnect to both imap servers\n", + ) ; + myprint( "For now only one signal $signame within $INTERVAL_TO_EXIT seconds.\n" ) ; + + if ( ! defined $mysync->{imap1} ) { return ; } + if ( ! defined $mysync->{imap2} ) { return ; } + + myprint( "Info: reconnecting to host1 imap server $mysync->{host1}\n" ) ; + $mysync->{imap1}->State( Mail::IMAPClient::Unconnected ) ; + $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT} += 1 ; + if ( $mysync->{imap1}->reconnect( ) ) + { + myprint( "Info: reconnected to host1 imap server $mysync->{host1}\n" ) ; + } + else + { + $mysync->{nb_errors}++ ; + exit_clean( $mysync, $EXIT_CONNECTION_FAILURE ) ; + } + myprint( "Info: reconnecting to host2 imap server\n" ) ; + $mysync->{imap2}->State( Mail::IMAPClient::Unconnected ) ; + $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT} += 1 ; + if ( $mysync->{imap2}->reconnect( ) ) + { + myprint( "Info: reconnected to host2 imap server $mysync->{host2}\n" ) ; + } + else + { + $mysync->{nb_errors}++ ; + exit_clean( $mysync, $EXIT_CONNECTION_FAILURE ) ; + } + myprint( "Info: reconnected to both imap servers\n" ) ; + } + return ; +} + +sub install_signals +{ + my $mysync = shift @ARG ; + + if ( under_docker_context( $mysync ) ) + { + # output( $mysync, "Under docker context so leaving signals as they are\n" ) ; + output( $mysync, "Under docker context so installing only signals to exit\n" ) ; + @{ $mysync->{ sigexit } } = ( defined( $mysync->{ sigexit } ) ) ? @{ $mysync->{ sigexit } } : ( 'INT', 'QUIT', 'TERM' ) ; + sig_install( $mysync, 'catch_exit', @{ $mysync->{ sigexit } } ) ; + } + else + { + # Unix signals + @{ $mysync->{ sigexit } } = ( defined( $mysync->{ sigexit } ) ) ? @{ $mysync->{ sigexit } } : ( 'QUIT', 'TERM' ) ; + @{ $mysync->{ sigreconnect } } = ( defined( $mysync->{ sigreconnect } ) ) ? @{ $mysync->{ sigreconnect } } : ( 'INT' ) ; + @{ $mysync->{ sigprint } } = ( defined( $mysync->{ sigprint } ) ) ? @{ $mysync->{ sigprint } } : ( 'HUP' ) ; + @{ $mysync->{ sigignore } } = ( defined( $mysync->{ sigignore } ) ) ? @{ $mysync->{ sigignore } } : ( ) ; + + #local %SIG = %SIG ; + sig_install( $mysync, 'catch_exit', @{ $mysync->{ sigexit } } ) ; + sig_install( $mysync, 'catch_reconnect', @{ $mysync->{ sigreconnect } } ) ; + sig_install( $mysync, 'catch_print', @{ $mysync->{ sigprint } } ) ; + # --sigignore can override sigexit, sigreconnect and sigprint (for the same signals only) + sig_install( $mysync, 'catch_ignore', @{ $mysync->{ sigignore } } ) ; + + # remove/add sleeping mechanism when receiving USR1 signal (except on Win32) + sig_install_toggle_sleep( $mysync ) ; + } + + return ; +} + + + +sub tests_reconnect_12_if_needed +{ + note( 'Entering tests_reconnect_12_if_needed()' ) ; + + my $mysync ; + + $mysync->{imap1} = Mail::IMAPClient->new( ) ; + $mysync->{imap2} = Mail::IMAPClient->new( ) ; + $mysync->{imap1}->Server( 'test1.lamiral.info' ) ; + $mysync->{imap2}->Server( 'test2.lamiral.info' ) ; + is( 2, reconnect_12_if_needed( $mysync ), 'reconnect_12_if_needed: test1&test2 .lamiral.info => 1' ) ; + is( 1, $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_12_if_needed: test1.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ; + is( 1, $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_12_if_needed: test2.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ; + + note( 'Leaving tests_reconnect_12_if_needed()' ) ; + return ; +} + +sub reconnect_12_if_needed +{ + my $mysync = shift @ARG ; + #return 2 ; + if ( ! reconnect_if_needed( $mysync->{imap1} ) ) { + return ; + } + if ( ! reconnect_if_needed( $mysync->{imap2} ) ) { + return ; + } + # both were good + return 2 ; +} + + +sub tests_reconnect_if_needed +{ + note( 'Entering tests_reconnect_if_needed()' ) ; + + + my $myimap ; + + is( undef, reconnect_if_needed( ), 'reconnect_if_needed: no args => undef' ) ; + is( undef, reconnect_if_needed( $myimap ), 'reconnect_if_needed: undef arg => undef' ) ; + + $myimap = Mail::IMAPClient->new( ) ; + $myimap->Debug( 1 ) ; + is( undef, reconnect_if_needed( $myimap ), 'reconnect_if_needed: empty new Mail::IMAPClient => undef' ) ; + $myimap->Server( 'test.lamiral.info' ) ; + is( 1, reconnect_if_needed( $myimap ), 'reconnect_if_needed: test.lamiral.info => 1' ) ; + is( 1, $myimap->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_if_needed: test.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ; + + note( 'Leaving tests_reconnect_if_needed()' ) ; + return ; +} + +sub reconnect_if_needed +{ + # return undef upon failure. + # return 1 upon connection success, with or without reconnection. + + my $imap = shift @ARG ; + + if ( ! defined $imap ) { return ; } + if ( ! $imap->Server( ) ) { return ; } + + if ( $imap->IsUnconnected( ) ) { + $imap->{IMAPSYNC_RECONNECT_COUNT} += 1 ; + if ( $imap->reconnect( ) ) { + return 1 ; + } + }else{ + return 1 ; + } + + # A last forced one + $imap->State( Mail::IMAPClient::Unconnected ) ; + $imap->reconnect( ) ; + $imap->{IMAPSYNC_RECONNECT_COUNT} += 1 ; + if ( $imap->noop ) { + # NOOP is ok + return 1 ; + } + + return ; +} + + +sub justconnect +{ + my $mysync = shift @ARG ; + my $justconnect1 = justconnect1( $sync ) ; + my $justconnect2 = justconnect2( $sync ) ; + return "$justconnect1 $justconnect2"; +} + +sub justconnect1 +{ + my $mysync = shift @ARG ; + if ( $mysync->{host1} ) + { + myprint( "Host1: Will just connect to $mysync->{host1} without login\n" ) ; + $mysync->{imap1} = connect_imap( + $mysync->{host1}, $mysync->{port1}, + $mysync->{ssl1}, $mysync->{tls1}, + $mysync->{ acc1 } ) ; + + imap_id( $mysync, $mysync->{imap1}, $mysync->{ acc1 }->{ Side } ) ; + $mysync->{imap1}->logout( ) ; + return $mysync->{host1} ; + } + + return q{} ; +} + +sub justconnect2 +{ + my $mysync = shift @ARG ; + if ( $mysync->{host2} ) + { + myprint( "Host2: Will just connect to $mysync->{host2} without login\n" ) ; + $mysync->{imap2} = connect_imap( + $mysync->{host2}, $mysync->{port2}, + $mysync->{ssl2}, $mysync->{tls2}, + $mysync->{ acc2 } ) ; + + imap_id( $mysync, $mysync->{imap2}, $mysync->{ acc2 }->{ Side } ) ; + $mysync->{imap2}->logout( ) ; + return $mysync->{host2} ; + } + + return q{} ; +} + +sub skip_macosx +{ + #return ; + # hostname is sometimes "macosx.polarhome.com" sometimes "macosx" + return( ( ( 'macosx.polarhome.com' eq hostname( ) ) || ( 'macosx' eq hostname( ) ) ) + && ( 'darwin' eq $OSNAME ) ) ; +} + +sub skip_macosx_binary +{ + #return ; + return( skip_macosx( ) && ( $PROGRAM_NAME =~ m{imapsync_bin_Darwin} ) ) ; +} + + + +sub tests_mailimapclient_connect +{ + note( 'Entering tests_mailimapclient_connect()' ) ; + + my $imap ; + # ipv4 + ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv4: new' ) ; + is( 'Mail::IMAPClient', ref( $imap ), 'mailimapclient_connect ipv4: ref is Mail::IMAPClient' ) ; + + # Mail::IMAPClient 3.40 die on this... So we skip it, thanks to "mature" IO::Socket::IP + # Mail::IMAPClient 3.42 is ok so this test is back. + is( undef, $imap->connect( ), 'mailimapclient_connect ipv4: connect with no server => failure' ) ; + + + is( 'test.lamiral.info', $imap->Server( 'test.lamiral.info' ), 'mailimapclient_connect ipv4: setting Server(test.lamiral.info)' ) ; + is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4: setting Debug( 1 )' ) ; + is( 143, $imap->Port( 143 ), 'mailimapclient_connect ipv4: setting Port( 143 )' ) ; + is( 10, $imap->Timeout( 10 ), 'mailimapclient_connect ipv4: setting Timeout( 10 )' ) ; + like( ref( $imap->connect( ) ), qr/IO::Socket::INET|IO::Socket::IP/, 'mailimapclient_connect ipv4: connect to test.lamiral.info' ) ; + like( $imap->logout( ), qr/Mail::IMAPClient/, 'mailimapclient_connect ipv4: logout' ) ; + is( undef, undef $imap, 'mailimapclient_connect ipv4: free variable' ) ; + + # ipv4 + ssl + ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv4 + ssl: new' ) ; + is( 'test.lamiral.info', $imap->Server( 'test.lamiral.info' ), 'mailimapclient_connect ipv4 + ssl: setting Server(test.lamiral.info)' ) ; + is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4 + ssl: setting Debug( 1 )' ) ; + ok( $imap->Ssl( [ SSL_verify_mode => SSL_VERIFY_NONE, SSL_cipher_list => 'DEFAULT:!DH' ] ), 'mailimapclient_connect ipv4 + ssl: setting Ssl( SSL_VERIFY_NONE )' ) ; + is( 993, $imap->Port( 993 ), 'mailimapclient_connect ipv4 + ssl: setting Port( 993 )' ) ; + like( ref( $imap->connect( ) ), qr/IO::Socket::SSL/, 'mailimapclient_connect ipv4 + ssl: connect to test.lamiral.info' ) ; + like( $imap->logout( ), qr/Mail::IMAPClient/, 'mailimapclient_connect ipv4 + ssl: logout in ssl does not cause failure' ) ; + is( undef, undef $imap, 'mailimapclient_connect ipv4 + ssl: free variable' ) ; + + # ipv6 + ssl + + ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv6 + ssl: new' ) ; + is( 'petiteipv6.lamiral.info', $imap->Server( 'petiteipv6.lamiral.info' ), 'mailimapclient_connect ipv6 + ssl: setting Server petiteipv6.lamiral.info' ) ; + is( 10, $imap->Timeout( 10 ), 'mailimapclient_connect ipv6: setting Timeout( 10 )' ) ; + ok( $imap->Ssl( [ SSL_verify_mode => SSL_VERIFY_NONE, SSL_cipher_list => 'DEFAULT:!DH' ] ), 'mailimapclient_connect ipv6 + ssl: setting Ssl( SSL_VERIFY_NONE )' ) ; + is( 993, $imap->Port( 993 ), 'mailimapclient_connect ipv6 + ssl: setting Port( 993 )' ) ; + SKIP: { + if ( + 'CUILLERE' eq hostname() + or + skip_macosx() + or + -e '/.dockerenv' + or + 'pcHPDV7-HP' eq hostname() + ) + { + skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/macosx.polarhome.com/docker cannot do ipv6', 4 ) ; + } + + is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4 + ssl: setting Debug( 1 )' ) ; + + # It sounds stupid but it avoids failures on the next test about $imap->connect + is( '2a01:e34:ecde:70d0:223:54ff:fec2:36d7', resolv( 'petiteipv6.lamiral.info' ), 'resolv: petiteipv6.lamiral.info => 2a01:e34:ecde:70d0:223:54ff:fec2:36d7' ) ; + + like( ref( $imap->connect( ) ), qr/IO::Socket::SSL/, 'mailimapclient_connect ipv6 + ssl: connect to petiteipv6.lamiral.info' ) ; + # This one is ok on petite, not on ks2, do not know why, so commented. + like( ref( $imap->logout( ) ), qr/Mail::IMAPClient/, 'mailimapclient_connect ipv6 + ssl: logout in ssl is ok on petiteipv6.lamiral.info' ) ; + } + + is( undef, undef $imap, 'mailimapclient_connect ipv6 + ssl: free variable' ) ; + + + note( 'Leaving tests_mailimapclient_connect()' ) ; + return ; +} + + +sub tests_mailimapclient_connect_bug +{ + note( 'Entering tests_mailimapclient_connect_bug()' ) ; + + my $imap ; + + # ipv6 + ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect_bug ipv6: new' ) ; + is( 'ks6ipv6.lamiral.info', $imap->Server( 'ks6ipv6.lamiral.info' ), 'mailimapclient_connect_bug ipv6: setting Server(ks6ipv6.lamiral.info)' ) ; + is( 143, $imap->Port( 143 ), 'mailimapclient_connect_bug ipv6: setting Port( 993 )' ) ; + + SKIP: { + if ( + 'CUILLERE' eq hostname() + or + skip_macosx() + or + -e '/.dockerenv' + or + 'pcHPDV7-HP' eq hostname() + ) + { + skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/macosx.polarhome.com/docker cannot do ipv6', 1 ) ; + } + like( ref( $imap->connect( ) ), qr/IO::Socket::INET/, 'mailimapclient_connect_bug ipv6: connect to ks6ipv6.lamiral.info' ) + or diag( 'mailimapclient_connect_bug ipv6: ', $imap->LastError( ), $!, ) ; + } + #is( $imap->logout( ), undef, 'mailimapclient_connect_bug ipv6: logout in ssl causes failure' ) ; + is( undef, undef $imap, 'mailimapclient_connect_bug ipv6: free variable' ) ; + + note( 'Leaving tests_mailimapclient_connect_bug()' ) ; + return ; +} + + + +sub tests_connect_socket +{ + note( 'Entering tests_connect_socket()' ) ; + + is( undef, connect_socket( ), 'connect_socket: no args' ) ; + + my $socket ; + my $imap ; + SKIP: { + if ( + 'CUILLERE' eq hostname() + or + skip_macosx() + or + -e '/.dockerenv' + or + 'pcHPDV7-HP' eq hostname() + ) + { + skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/macosx.polarhome.com/docker cannot do ipv6', 2 ) ; + } + + $socket = IO::Socket::INET6->new( + PeerAddr => 'ks6ipv6.lamiral.info', + PeerPort => 143, + ) ; + + + ok( $imap = connect_socket( $socket ), 'connect_socket: ks6ipv6.lamiral.info port 143 IO::Socket::INET6' ) ; + #$imap->Debug( 1 ) ; + # myprint( $imap->capability( ) ) ; + if ( $imap ) { + $imap->logout( ) ; + } + + $IO::Socket::SSL::DEBUG = 4 ; + $socket = IO::Socket::SSL->new( + PeerHost => 'ks6ipv6.lamiral.info', + PeerPort => 993, + SSL_verify_mode => SSL_VERIFY_NONE, + SSL_cipher_list => 'DEFAULT:!DH', + ) ; + # myprint( $socket ) ; + ok( $imap = connect_socket( $socket ), 'connect_socket: ks6ipv6.lamiral.info port 993 IO::Socket::SSL' ) ; + #$imap->Debug( 1 ) ; + # myprint( $imap->capability( ) ) ; + # $socket->close( ) ; + if ( $imap ) { + $socket->close( ) ; + } + #$socket->close(SSL_no_shutdown => 1) ; + #$imap->logout( ) ; + #myprint( "\n" ) ; + #$imap->logout( ) ; + } + note( 'Leaving tests_connect_socket()' ) ; + return ; +} + +sub connect_socket +{ + my( $socket ) = @ARG ; + + if ( ! defined $socket ) { return ; } + + my $host = $socket->peerhost( ) ; + my $port = $socket->peerport( ) ; + #print "socket->peerhost: ", $socket->peerhost( ), "\n" ; + #print "socket->peerport: ", $socket->peerport( ), "\n" ; + my $imap = Mail::IMAPClient->new( ) ; + $imap->Socket( $socket ) ; + my $banner = $imap->Results()->[0] ; + #myprint( "banner: $banner" ) ; + return $imap ; +} + + +sub tests_probe_imapssl +{ + note( 'Entering tests_probe_imapssl()' ) ; + + is( undef, probe_imapssl( ), 'probe_imapssl: no args => undef' ) ; + is( undef, probe_imapssl( 'unknown' ), 'probe_imapssl: unknown => undef' ) ; + + note( "hostname is: ", hostname() ) ; + SKIP: { + if ( + 'CUILLERE' eq hostname() + or + skip_macosx() + or + -e '/.dockerenv' + or + 'pcHPDV7-HP' eq hostname() + ) + { + skip( 'Tests avoided on CUILLERE or pcHPDV7-HP or Mac or docker: cannot do ipv6', 0 ) ; + } + # fed up with this one + #like( probe_imapssl( 'ks6ipv6.lamiral.info' ), qr/^\* OK/, 'probe_imapssl: ks6ipv6.lamiral.info matches "* OK"' ) ; + } ; + + + # It sounds stupid but it avoids failures on the next test about $imap->connect + ok( resolv( 'imap.gmail.com' ), 'resolv: imap.gmail.com => something' ) ; + like( probe_imapssl( 'imap.gmail.com' ), qr/^\* OK/, 'probe_imapssl: imap.gmail.com matches "* OK"' ) ; + + like( probe_imapssl( 'test1.lamiral.info' ), qr/^\* OK/, 'probe_imapssl: test1.lamiral.info matches "* OK"' ) ; + + note( 'Leaving tests_probe_imapssl()' ) ; + return ; +} + + +sub probe_imapssl +{ + my $host = shift @ARG ; + + if ( ! $host ) { return ; } + $sync->{ debug } and $IO::Socket::SSL::DEBUG = 4 ; + my $socket = IO::Socket::SSL->new( + PeerHost => $host, + PeerPort => $IMAP_SSL_PORT, + SSL_verifycn_scheme => 'imap', + SSL_verify_mode => $SSL_VERIFY_POLICY, + SSL_cipher_list => 'DEFAULT:!DH', + ) ; + if ( ! $socket ) { return ; } + $sync->{ debug } and print "socket: $socket\n" ; + + my $banner ; + $socket->sysread( $banner, 65_536 ) ; + $sync->{ debug } and print "banner: $banner" ; + $socket->close( ) ; + return $banner ; + +} + +sub connect_imap +{ + my( $host, $port, $ssl, $tls, $acc ) = @_ ; + my $imap = Mail::IMAPClient->new( ) ; + + if ( $ssl ) { set_ssl( $imap, $acc ) } + $imap->Server( $host ) ; + $imap->Port( $port ) ; + $imap->Debug( $acc->{ debugimap } ) ; + $imap->Timeout( $acc->{ timeout } ) ; + + #$imap->Keepalive( $acc->{ keepalive } ) ; + + + my $side = lc $acc->{ Side } ; + + myprint( "$acc->{ Side }: connecting on $side [$host] port [$port]\n" ) ; + + if ( ! $imap->connect( ) ) + { + $sync->{nb_errors}++ ; + exit_clean( $sync, $EXIT_CONNECTION_FAILURE, + "$acc->{ Side }: Can not open imap connection on [$host]: ", + $imap->LastError, + " $OS_ERROR\n" + ) ; + } + myprint( "$acc->{ Side } IP address: ", $imap->Socket->peerhost(), " Local IP address: ", $imap->Socket->sockhost(), "\n" ) ; + my $banner = $imap->Results()->[0] ; + + myprint( "$acc->{ Side } banner: $banner" ) ; + myprint( "$acc->{ Side } capability: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ; + + if ( $tls ) { + set_tls( $imap, $acc ) ; + if ( ! $imap->starttls( ) ) + { + $sync->{nb_errors}++ ; + exit_clean( $sync, $EXIT_TLS_FAILURE, + "$acc->{ Side }: Can not go to tls encryption on $side [$host]:", + $imap->LastError, "\n" + ) ; + } + myprint( "$acc->{ Side }: Socket successfully converted to SSL\n" ) ; + } + return( $imap ) ; +} + +sub tests_compress_ssl +{ + note( 'Entering tests_compress_ssl()' ) ; + + SKIP: { + if ( skip_macosx( ) ) + { + skip( 'Tests avoided on host polarhome macosx, no clue "ssl3_get_server_certificate:certificate verify failed"', 12 ) ; + } + else + { + my $myimap ; + my $acc = {} ; + $acc->{ Side } = 'HostK' ; + $acc->{ authmech } = 'LOGIN' ; + $acc->{ debugimap } = 1 ; + $acc->{ compress } = 1 ; + $acc->{ N } = 'K' ; + + ok( + $myimap = login_imap( 'test1.lamiral.info', 993, 'test1', 'secret1', + 1, undef, + 1, 100, $acc, {}, + ), 'acc_compress_imap: test1.lamiral.info test1 ssl' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 ssl IsAuthenticated' ) ; + + + is( $acc->{ imap }, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info ok" ) ; + is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info 2nd nok" ) ; + + ok( + $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', + 0, undef, + 1, 100, $acc, {}, + ), 'acc_compress_imap: test1.lamiral.info test1 tls' ) ; + ok( $myimap && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 tls IsAuthenticated' ) ; + + is( $acc->{ imap }, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info tls ok" ) ; + is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info tls 2nd nok" ) ; + + # Third, no compression + $acc->{ compress } = 0 ; + ok( + $myimap = login_imap( 'test1.lamiral.info', 993, 'test1', 'secret1', + 1, undef, + 1, 100, $acc, {}, + ), 'acc_compress_imap: test1.lamiral.info test1 ssl' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 ssl IsAuthenticated' ) ; + + + is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info off ok" ) ; + is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info 2nd off ok" ) ; + + } + } + note( 'Leaving tests_compress_ssl()' ) ; + return ; +} + +sub tests_compress +{ + note( 'Entering tests_compress()' ) ; + + my $myimap ; + my $acc = {} ; + $acc->{ Side } = 'HostK' ; + $acc->{ authmech } = 'LOGIN' ; + $acc->{ debugimap } = 1 ; + $acc->{ compress } = 1 ; + $acc->{ N } = 'K' ; + + ok( + $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', + 0, 0, + 1, 100, $acc, {}, + ), 'acc_compress_imap: test1.lamiral.info test1' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 IsAuthenticated' ) ; + + + is( $acc->{ imap }, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info ok" ) ; + is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info 2nd nok" ) ; + + ok( + $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', + 0, 0, + 1, 100, $acc, {}, + ), 'acc_compress_imap: test1.lamiral.info test1 tls' ) ; + ok( $myimap && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 tls IsAuthenticated' ) ; + + is( $acc->{ imap }, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info tls ok" ) ; + is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info tls 2nd nok" ) ; + + # Third, no compression + $acc->{ compress } = 0 ; + ok( + $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', + 0, 0, + 1, 100, $acc, {}, + ), 'acc_compress_imap: test1.lamiral.info test1 ssl' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'acc_compress_imap: test1.lamiral.info test1 ssl IsAuthenticated' ) ; + + + is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info off ok" ) ; + is( undef, acc_compress_imap( $acc ), "acc_compress_imap: test1.lamiral.info 2nd off ok" ) ; + + note( 'Leaving tests_compress()' ) ; + return ; +} + + +sub acc_compress_imap +{ + my $acc = shift @ARG ; + + if ( ! defined( $acc ) ) { return ; } + + my $ret ; + my $imap = $acc->{ imap } ; + if ( ! defined $imap ) { return ; } + + if ( $imap && $acc->{ compress } ) + { + myprint( "$acc->{ Side }: Trying to turn imap compression on. Use --nocompress" . $acc->{ N } . " to avoid compression on " . lc( $acc->{ Side } ) . "\n" ) ; + if ( $ret = $imap->compress() ) + { + myprint( "$acc->{ Side }: Compression is on now\n" ) ; + } + else + { + myprint( "$acc->{ Side }: Failed to turn compression on\n" ) ; + } + } + else + { + myprint( "$acc->{ Side }: Compression is off. Use --compress" . $acc->{ N } . " to allow compression on " . lc( $acc->{ Side } ) . "\n" ) ; + } + # $ret is $acc->{ imap } on success, undef on failure or when there is nothing to do. + return $ret ; +} + +sub tests_login_imap +{ + note( 'Entering tests_login_imap()' ) ; + + is( undef, login_imap( ), 'login_imap: no args => undef' ) ; + + SKIP: { + if ( skip_macosx( ) ) + { + skip( 'Tests avoided only on binary on host polarhome macosx, no clue "ssl3_get_server_certificate:certificate verify failed"', 15 ) ; + } + else{ + + my $myimap ; + my $acc = {} ; + $acc->{ Side } = 'HostK' ; + $acc->{ authmech } = 'LOGIN' ; + #$IO::Socket::SSL::DEBUG = 4 ; + # Each month (trimester?): + # echo | openssl s_client -crlf -connect test1.lamiral.info:993 + # ... + # certificate has expired + # Fix: ssh root@test1.lamiral.info 'apt update && apt upgrade && /etc/init.d/dovecot restart' + # + # or this one: + # echo | openssl s_client -crlf -connect test1.lamiral.info:993 + # ... + # Verify return code: 9 (certificate is not yet valid) + # Fix: /etc/init.d/openntpd restart + # 2021_09_04 done + ok( + $myimap = login_imap( 'test1.lamiral.info', 993, 'test1', 'secret1', + 1, undef, + 1, 100, $acc, {}, + ), 'login_imap: test1.lamiral.info test1 ssl' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: test1.lamiral.info test1 ssl IsAuthenticated' ) ; + + is( $myimap, $acc->{ imap }, "login_imap: acc->{ imap } ok test1 ssl") ; + + ok( + $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', + 0, undef, + 1, 100, $acc, {}, + ), 'login_imap: test1.lamiral.info test1 tls' ) ; + ok( $myimap && $myimap->IsAuthenticated( ), 'login_imap: test1.lamiral.info test1 tls IsAuthenticated' ) ; + is( $myimap, $acc->{ imap }, "login_imap: acc->{ imap } ok test1 tls") ; + + #$IO::Socket::SSL::DEBUG = 4 ; + $acc->{sslargs} = { SSL_version => 'SSLv2' } ; + # SSLv2 not supported + is( + undef, $myimap = login_imap( 'test1.lamiral.info', 143, 'test1', 'secret1', + 0, undef, + 1, 100, $acc, {}, + ), 'login_imap: test1.lamiral.info test1 tls SSLv2 not supported' ) ; +#SSL_verify_mode => 1 +#SSL_version => 'TLSv1_1' + is( undef, $acc->{ imap }, "login_imap: acc->{ imap } test1 tls error => undef") ; + + + # I have left ? exit_clean to be replaced by errors_incr( $mysync, 'error message' ) + # 1 in login_imap() + + + my $mysync = {} ; + $acc = {} ; + $acc->{ Side } = 'Host2' ; + $acc->{ authmech } = 'LOGIN' ; + is( + undef, login_imap( 'noresol.lamiral.info', 143, 'test1', 'secret1', + 0, undef, + 1, 100, $acc, $mysync, + ), 'login_imap: noresol.lamiral.info undef' ) ; + + is( 'ERR_CONNECTION_FAILURE_HOST2', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host2 noresol.lamiral.info => ERR_CONNECTION_FAILURE_HOST2' ) ; + is( undef, $acc->{ imap }, "login_imap: acc->{ imap } noresol error => undef") ; + + # authentication failure for user2 + $mysync = {} ; + is( + undef, login_imap( 'test1.lamiral.info', 143, 'test1', 'Ce crétin', + 0, undef, + 1, 100, $acc, $mysync, + ), 'login_imap: user2 bad passord => undef' ) ; + + is( 'ERR_AUTHENTICATION_FAILURE_USER2', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host2 bad password => ERR_AUTHENTICATION_FAILURE_USER2' ) ; + + # authentication failure for user1 + $mysync = {} ; + $acc = {} ; + $acc->{ Side } = 'Host1' ; + $acc->{ authmech } = 'LOGIN' ; + is( + undef, login_imap( 'test1.lamiral.info', 143, 'test1', 'Ce crétin', + 0, undef, + 1, 100, $acc, $mysync, + ), 'login_imap: user1 bad passord => undef' ) ; + + is( 'ERR_AUTHENTICATION_FAILURE_USER1', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host1 bad password => ERR_AUTHENTICATION_FAILURE_USER1' ) ; + + } + } + + note( 'Leaving tests_login_imap()' ) ; + return ; +} + +sub oauthgenerateaccess +{ + if ( "petite" eq hostname() ) + { + myprint( "oauthgenerateaccess\n" ) ; + my @output = backtick( 'cd oauth2 && pwd && ./generate_gmail_token imapsync.gl0@gmail.com' ) ; + myprint( @output ) ; + } + return ; +} + +sub tests_login_imap_oauth +{ + note( 'Entering tests_login_imap_oauth()' ) ; + + oauthgenerateaccess() ; + + SKIP: { + if ( skip_macosx_binary( ) ) + { + skip( 'Tests avoided only on binary on host polarhome macosx, no clue "ssl3_get_server_certificate:certificate verify failed"', 6 ) ; + } + else + { + + my $mysync ; + my $acc ; + # oauthdirect authentication failure for user2 + $mysync = {} ; + $acc = {} ; + $acc->{ oauthdirect } = 'caca2' ; + $acc->{ debugimap } = 1 ; + $mysync->{ showpasswords } = 1 ; + $acc->{ Side } = 'Host2' ; + $acc->{ authmech } = 'QQQ' ; + is( + undef, login_imap( 'imap.gmail.com', 993, 'test1', 'Ce crétin', + 1, undef, + 1, 100, $acc, $mysync, + ), 'login_imap: user2 bad oauthdirect => undef' ) ; + + is( 'ERR_AUTHENTICATION_FAILURE_USER2', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host2 bad oauthdirect => ERR_AUTHENTICATION_FAILURE_USER2' ) ; + + # oauthdirect authentication failure for user1 + $mysync = {} ; + $acc = {} ; + $acc->{ Side } = 'Host1' ; + $acc->{ oauthdirect } = 'caca1' ; + $acc->{ debugimap } = 1 ; + $mysync->{ showpasswords } = 1 ; + $acc->{ authmech } = 'QQQ' ; + is( + undef, login_imap( 'imap.gmail.com', 993, 'test1', 'Ce crétin', + 1, undef, + 1, 100, $acc, $mysync, + ), 'login_imap: user1 bad oauthdirect => undef' ) ; + + is( 'ERR_AUTHENTICATION_FAILURE_USER1', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host1 bad oauthdirect => ERR_AUTHENTICATION_FAILURE_USER1' ) ; + + # oauthdirect authentication failure for user1 + $mysync = {} ; + $acc = {} ; + $acc->{ Side } = 'Host1' ; + $acc->{ oauthdirect } = '' ; + $acc->{ debugimap } = 1 ; + $mysync->{ showpasswords } = 1 ; + $acc->{ authmech } = 'QQQ' ; + is( + undef, login_imap( 'imap.gmail.com', 993, 'test1', 'Ce crétin', + 1, undef, + 1, 100, $acc, $mysync, + ), 'login_imap: user1 bad oauthdirect => undef' ) ; + + is( 'ERR_AUTHENTICATION_FAILURE_USER1', errorsanalyse( errors_log( $mysync ) ), 'login_imap: Host1 no oauthdirect value => ERR_AUTHENTICATION_FAILURE_USER1' ) ; + + } + } + + # oauthdirect authentication success for user1 + SKIP: { + if ( ! -r 'oauth2/D_oauth2_oauthdirect_imapsync.gl0@gmail.com.txt' ) + { + skip( 'oauthdirect: no oauthdirect file', 6 ) ; + } + my $myimap ; + my $mysync = {} ; + my $acc = {} ; + $acc->{ Side } = 'Host1' ; + $acc->{ oauthdirect } = 'oauth2/D_oauth2_oauthdirect_imapsync.gl0@gmail.com.txt' ; + $acc->{ debugimap } = 1 ; + $mysync->{ showpasswords } = 1 ; + $acc->{ authmech } = 'QQQ' ; + isa_ok( + $myimap = login_imap( 'imap.gmail.com', 993, 'user_useless', 'password_useless', + 1, undef, + 1, 100, $acc, $mysync, + ), 'Mail::IMAPClient', 'login_imap: user1 good oauthdirect => Mail::IMAPClient' ) ; + + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthdirect IsAuthenticated' ) ; + + ok( defined( $myimap ) && $myimap->logout( ), 'login_imap: gmail oauth2 oauthdirect logout' ) ; + ok( defined( $myimap ) && ! $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthdirect not IsAuthenticated after logout' ) ; + ok( defined( $myimap ) && $myimap->reconnect( ), 'login_imap: gmail oauth2 oauthdirect reconnect ok' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthdirect IsAuthenticated after reconnect' ) ; + } + + + + # oauthaccesstoken authentication success for user1 + SKIP: { + if ( ! -r 'oauth2/D_oauth2_access_token_imapsync.gl0@gmail.com.txt' ) + { + skip( 'oauthaccesstoken: no access_token file', 6 ) ; + } + my $myimap ; + my $mysync = {} ; + my $acc = {} ; + $acc->{ Side } = 'Host1' ; + $acc->{ oauthaccesstoken } = 'oauth2/D_oauth2_access_token_imapsync.gl0@gmail.com.txt' ; + $acc->{ debugimap } = 1 ; + $mysync->{ showpasswords } = 1 ; + $acc->{ authmech } = 'QQQ' ; + isa_ok( + $myimap = login_imap( 'imap.gmail.com', 993, 'imapsync.gl0@gmail.com', 'password_useless', + 1, undef, + 1, 100, $acc, $mysync, + ), 'Mail::IMAPClient', 'login_imap: user1 good oauthaccesstoken => Mail::IMAPClient' ) ; + + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthaccesstoken IsAuthenticated' ) ; + + ok( defined( $myimap ) && $myimap->logout( ), 'login_imap: gmail oauth2 oauthaccesstoken logout' ) ; + ok( defined( $myimap ) && ! $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthaccesstoken not IsAuthenticated after logout' ) ; + ok( defined( $myimap ) && $myimap->reconnect( ), 'login_imap: gmail oauth2 oauthaccesstoken reconnect ok' ) ; + ok( defined( $myimap ) && $myimap->IsAuthenticated( ), 'login_imap: gmail oauth2 oauthaccesstoken IsAuthenticated after reconnect' ) ; + } + + + note( 'Leaving tests_login_imap_oauth()' ) ; + return ; +} + + + +sub login_imap +{ + my @allargs = @_ ; + my( + $host, $port, $user, $password, + $ssl, $tls, + $uid, $split, $acc, $mysync ) = @allargs ; + + $acc->{ imap } = undef ; + + if ( ! all_defined( $host, $port, $user, $acc->{ Side } ) ) + { + return ; + } + + my $side = lc $acc->{ Side } ; + myprint( "$acc->{ Side }: connecting and login on $side [$host] port [$port] with user [$user]\n" ) ; + + my $imap = init_imap( @allargs ) ; + + if ( ! $imap->connect() ) + { + my $error = "$acc->{ Side } failure: can not open imap connection on $side [$host] with user [$user]: " + . $imap->LastError . " $OS_ERROR\n" ; + errors_incr( $mysync, $error ) ; + return ; + } + + # Add also $imap->Socket->sockhost() to help configuring firewalls, allowed rule. + myprint( "$acc->{ Side } IP address: ", $imap->Socket->peerhost(), " Local IP address: ", $imap->Socket->sockhost(), "\n" ) ; + my $banner = $imap->Results()->[0] ; + + myprint( "$acc->{ Side } banner: $banner" ) ; + myprint( "$acc->{ Side } capability before authentication: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ; + + if ( (! $ssl) and (! defined $tls ) and $imap->has_capability( 'STARTTLS' ) ) { + myprint( "$acc->{ Side }: going to ssl because STARTTLS is in CAPABILITY. Use --notls1 or --notls2 to avoid that behavior\n" ) ; + $tls = 1 ; + } + + + #myprint( Data::Dumper->Dump( [ @allargs ] ) ) ; + if ( $tls ) { + set_tls( $imap, $acc ) ; + + if ( ! $imap->starttls( ) ) + { + my $error = "$acc->{ Side } failure: Can not go to tls encryption on $side [$host]: " + . $imap->LastError . "\n" ; + + errors_incr( $mysync, $error ) ; + return ; + } + myprint( "$acc->{ Side }: Socket successfully converted to SSL\n" ) ; + } + + if ( $acc->{ authmech } eq 'PREAUTH' ) { + if ( $imap->IsAuthenticated( ) ) { + $imap->Socket ; + myprintf("%s: Assuming PREAUTH for %s\n", $acc->{ Side }, $imap->Server ) ; + }else{ + $mysync->{nb_errors}++ ; + exit_clean( + $mysync, $EXIT_AUTHENTICATION_FAILURE, + "$acc->{ Side } failure: error login on $side [$host] with user [$user] auth [PREAUTH]\n" + ) ; + } + } + + + + if ( authenticate_imap( $imap, @allargs ) ) + { + myprint( "$acc->{ Side }: success login on [$host] with user [$user] auth [$acc->{ authmech }] or [LOGIN]\n" ) ; + $acc->{ imap } = $imap ; + return( $imap ) ; + } + else + { + # The errors are already printed + myprint( "$acc->{ Side }: failed login on [$host] with user [$user] auth [$acc->{ authmech }]\n" ) ; + return ; + } +} + + + +sub init_imap +{ + my( + $host, $port, $user, $password, + $ssl, $tls, + $uid, $split, $acc, $mysync ) = @_ ; + + my ( $imap ) ; + + $imap = Mail::IMAPClient->new() ; + + # Well, it does not change anything, does it? + # It does when suppressing the hack with *STDERR + $imap->Debug_fh( $mysync->{ tee } || *STDOUT ) ; + + if ( $ssl ) { set_ssl( $imap, $acc ) } + if ( $tls ) { } # can not do set_tls() here because connect() will directly do a STARTTLS + $imap->Clear( 1 ) ; + $imap->Server( $host ) ; + $imap->Port( $port ) ; + $imap->Fast_io( $acc->{ fastio } ) ; + $imap->Buffer( $buffersize || $DEFAULT_BUFFER_SIZE ) ; + $imap->Uid( $uid ) ; + + $imap->Peek( 1 ) ; + $imap->Debug( $acc->{ debugimap } ) ; + if ( $mysync->{ showpasswords } ) { + $imap->Showcredentials( 1 ) ; + } + + if ( defined( $acc->{ timeout } ) ) + { + $imap->Timeout( $acc->{ timeout } ) ; + } + + if ( defined $acc->{ keepalive } ) + { + $imap->Keepalive( $acc->{ keepalive } ) ; + } + + if ( defined $acc->{ reconnectretry } ) + { + $imap->Reconnectretry( $acc->{ reconnectretry } ) ; + } + + $imap->{IMAPSYNC_RECONNECT_COUNT} = 0 ; + $imap->Ignoresizeerrors( $allowsizemismatch ) ; + $split and $imap->Maxcommandlength( $SPLIT_FACTOR * $split ) ; + + + return( $imap ) ; + +} + +sub authenticate_imap +{ + my( $imap, + $host, $port, $user, $password, + $ssl, $tls, + $uid, $split, $acc, $mysync ) = @_ ; + + check_capability( $imap, $acc->{ authmech }, $acc->{ Side } ) ; + $imap->User( $user ) ; + + if ( defined $acc->{ domain } ) + { + $imap->Domain( $acc->{ domain } ) ; + $mysync->{ debug } and myprint( "Domain: $acc->{ domain }\n" ) ; + } + + $imap->Authuser( $acc->{ authuser } ) ; + $imap->Password( $password ) ; + + if ( 'X-MASTERAUTH' eq $acc->{ authmech } ) + { + xmasterauth( $imap ) ; + return 1 ; + } + + + if ( defined $acc->{ oauthdirect } ) + { + $acc->{ authmech } = 'XOAUTH2 direct' ; + return( oauthdirect( $mysync, $acc, $imap, $host, $user ) ) ; + } + + + if ( defined $acc->{ oauthaccesstoken } ) + { + $acc->{ authmech } = 'XOAUTH2 accesstoken' ; + return( oauthaccesstoken( $mysync, $acc, $imap, $host, $user ) ) ; + } + + + + + if ( $acc->{ proxyauth } ) { + $imap->Authmechanism(q{}) ; + $imap->User( $acc->{ authuser } ) ; + } else { + $imap->Authmechanism( $acc->{ authmech } ) unless ( $acc->{ authmech } eq 'LOGIN' or $acc->{ authmech } eq 'PREAUTH' ) ; + } + + $imap->Authcallback(\&xoauth2) if ( 'XOAUTH2' eq $acc->{ authmech } ) ; + $imap->Authcallback(\&plainauth) if ( ( 'PLAIN' eq $acc->{ authmech } ) or ( 'EXTERNAL' eq $acc->{ authmech } ) ) ; + + + unless ( $acc->{ authmech } eq 'PREAUTH' or $imap->login( ) ) { + my $info = "$acc->{ Side } failure: Error login on [$host] with user [$user] auth" ; + my $einfo = imap_last_error( $imap ) ; + my $error = "$info [$acc->{ authmech }]: $einfo\n" ; + + + if ( ( $acc->{ authmech } eq 'LOGIN' ) or $imap->IsUnconnected( ) or $acc->{ authuser } ) { + $acc->{ authuser } ||= "" ; + myprint( "$acc->{ Side } info: authmech [$acc->{ authmech }] user [$user] authuser [$acc->{ authuser }] IsUnconnected [", $imap->IsUnconnected( ), "]\n" ) ; + errors_incr( $mysync, $error ) ; + return ; + }else{ + errors_incr( $mysync, $error ) ; + } + + # It is not secure to try plain text LOGIN when another authmech failed + # but I do it anyway. This behavior is optional as option --notrylogin will skip it. + if ( $mysync->{ trylogin } ) + { + myprint( "$acc->{ Side } info: trying LOGIN Auth mechanism on [$host] with user [$user]. Use option --notrylogin to avoid this second chance to login via LOGIN auth\n" ) ; + $imap->Authmechanism(q{}) ; + if ( ! $imap->login( ) ) + { + failure_login( $mysync, $acc, 'LOGIN', $imap, $host, $user ) ; + return ; + } + else + { + myprint( "$acc->{ Side }: success login on [$host] with user [$user] auth [LOGIN] after [$acc->{ authmech }] failure\n" ) ; + } + } + else + { + myprint( "$acc->{ Side } info: not trying LOGIN Auth mechanism on [$host] with user [$user]. Use option --trylogin to have this second chance to login via LOGIN auth\n" ) ; + return ; + } + } + + if ( $acc->{ proxyauth } ) { + if ( ! $imap->proxyauth( $user ) ) { + failure_proxyauth( $mysync, $acc, $acc->{ authmech }, $imap, $host, $user ) ; + return ; + } + } + + return 1; +} + + +sub failure_login +{ + my( $mysync, $acc, $authmech, $imap, $host, $user ) = @ARG ; + my $info = "$acc->{ Side } failure: Error login on [$host] with user [$user] auth" ; + my $einfo = imap_last_error( $imap ) ; + my $error = "$info [$authmech]: $einfo\n" ; + errors_incr( $mysync, $error ) ; + return ; +} + +# failure_login and failure_proxyauth function are similar but +# variable $error so no factoring +sub failure_proxyauth +{ + my( $mysync, $acc, $authmech, $imap, $host, $user ) = @ARG ; + my $info = "$acc->{ Side } failure: Error login on [$host] with user [$user] auth" ; + my $einfo = imap_last_error( $imap ) ; + my $error = "$info [$authmech] using proxy-login as [$acc->{ authuser }]: $einfo\n" ; + errors_incr( $mysync, $error ) ; + return ; +} + + + + +sub oauthdirect +{ + my( $mysync, $acc, $imap, $host, $user ) = @_ ; + + my $oauthdirect_str ; + if ( -f -r $acc->{ oauthdirect } ) + { + $oauthdirect_str = firstline( $acc->{ oauthdirect } ) ; + } + else + { + $oauthdirect_str = $acc->{ oauthdirect } || 'Please define oauthdirect value' ; + } + + $imap->Authmechanism( 'XOAUTH2' ) ; + $imap->Authcallback( sub { return $oauthdirect_str } ) ; + + #if ( $imap->authenticate('XOAUTH2', sub { return $oauthdirect_str } ) ) + if ( $imap->login( ) ) + { + return 1 ; + } + else + { + failure_login( $mysync, $acc, $acc->{ authmech }, $imap, $host, $user ) ; + return ; + } + return ; +} + + + + +sub oauthaccesstoken +{ + my( $mysync, $acc, $imap, $host, $user ) = @_ ; + + my $oauthaccesstoken_str ; + if ( -f -r $acc->{ oauthaccesstoken } ) + { + $oauthaccesstoken_str = firstline( $acc->{ oauthaccesstoken } ) ; + } + else + { + $oauthaccesstoken_str = $acc->{ oauthaccesstoken } || 'Please define oauthaccesstoken value' ; + } + + my $oauth_string = "user=" . $user . "\x01auth=Bearer ". $oauthaccesstoken_str . "\x01\x01" ; + #myprint "oauth_string: $oauth_string\n" ; + + my $oauth_string_base64 = encode_base64( $oauth_string , '' ) ; + #myprint "oauth_string_base64: $oauth_string_base64\n" ; + + my $oauthdirect_str = $oauth_string_base64 ; + + $imap->Authmechanism( 'XOAUTH2' ) ; + $imap->Authcallback( sub { return $oauthdirect_str } ) ; + + #if ( $imap->authenticate('XOAUTH2', sub { return $oauthdirect_str } ) ) + if ( $imap->login( ) ) + { + return 1 ; + } + else + { + failure_login( $mysync, $acc, $acc->{ authmech }, $imap, $host, $user ) ; + return ; + } + return ; +} + + + + +sub check_capability +{ + + my( $imap, $authmech, $Side ) = @_ ; + + + if ( $imap->has_capability( "AUTH=$authmech" ) + or $imap->has_capability( $authmech ) ) + { + myprintf("%s: %s says it has CAPABILITY for AUTHENTICATE %s\n", + $Side, $imap->Server, $authmech) ; + return ; + } + + if ( $authmech eq 'LOGIN' ) + { + # Well, the warning is so common and useless that I prefer to remove it + # No more "... says it has NO CAPABILITY for AUTHENTICATE LOGIN" + return ; + } + + + myprintf( "%s: %s says it has NO CAPABILITY for AUTHENTICATE %s\n", + $Side, $imap->Server, $authmech ) ; + + if ( $authmech eq 'PLAIN' ) + { + myprint( "$Side: frequently PLAIN is only supported with SSL, try --ssl or --tls options\n" ) ; + } + + return ; +} + +sub set_ssl +{ + my ( $imap, $acc ) = @_ ; + # SSL_version can be + # SSLv3 SSLv2 SSLv23 SSLv23:!SSLv2 (last one is the default in IO-Socket-SSL-1.953) + # + + my $sslargs_hash = $acc->{sslargs} ; + + my $sslargs_default = { + SSL_verify_mode => $SSL_VERIFY_POLICY, + SSL_verifycn_scheme => 'imap', + SSL_cipher_list => 'DEFAULT:!DH', + } ; + + # initiate with default values + my %sslargs_mix = %{ $sslargs_default } ; + # now override with passed values + @sslargs_mix{ keys %{ $sslargs_hash } } = values %{ $sslargs_hash } ; + # remove keys with undef values + foreach my $key ( keys %sslargs_mix ) { + delete $sslargs_mix{ $key } if ( not defined $sslargs_mix{ $key } ) ; + } + # back to an ARRAY + my @sslargs_mix = %sslargs_mix ; + #myprint( Data::Dumper->Dump( [ $sslargs_hash, $sslargs_default, \%sslargs_mix, \@sslargs_mix ] ) ) ; + $imap->Ssl( \@sslargs_mix ) ; + return ; +} + +sub set_tls +{ + my ( $imap, $acc ) = @_ ; + + my $sslargs_hash = $acc->{sslargs} ; + + my $sslargs_default = { + SSL_verify_mode => $SSL_VERIFY_POLICY, + SSL_cipher_list => 'DEFAULT:!DH', + } ; + #myprint( Data::Dumper->Dump( [ $acc, $sslargs_hash, $sslargs_default ] ) ) ; + + # initiate with default values + my %sslargs_mix = %{ $sslargs_default } ; + # now override with passed values + @sslargs_mix{ keys %{ $sslargs_hash } } = values %{ $sslargs_hash } ; + # remove keys with undef values + foreach my $key ( keys %sslargs_mix ) { + delete $sslargs_mix{ $key } if ( not defined $sslargs_mix{ $key } ) ; + } + # back to an ARRAY + my @sslargs_mix = %sslargs_mix ; + + $imap->Starttls( \@sslargs_mix ) ; + return ; +} + + + +sub plainauth +{ + my $code = shift; + my $imap = shift; + + my $string = mysprintf("%s\x00%s\x00%s", $imap->User, + defined $imap->Authuser ? $imap->Authuser : "", $imap->Password); + return encode_base64("$string", q{}); +} + +# Copy from https://github.com/imapsync/imapsync/pull/25/files +# Changes "use" pragmas to "require". +# The openssl system call shall be replaced by pure Perl and +# https://metacpan.org/pod/Crypt::OpenSSL::PKCS12 + +# Now the Joaquin Lopez code: +# +# Used this as an example: https://gist.github.com/gsainio/6322375 +# +# And this as a reference: https://developers.google.com/accounts/docs/OAuth2ServiceAccount +# (note there is an http/rest tab, where the real info is hidden away... went on a witch hunt +# until I noticed that...) +# +# This is targeted at gmail to maintain compatibility after google's oauth1 service is deactivated +# on May 5th, 2015: https://developers.google.com/gmail/oauth_protocol +# If there are other oauth2 implementations out there, this would need to be modified to be +# compatible +# +# This is a good guide on setting up the google api/apps side of the equation: +# http://www.limilabs.com/blog/oauth2-gmail-imap-service-account +# +# 2016/05/27: Updated to support oauth/key data in the .json files Google now defaults to +# when creating gmail service accounts. They're easier to work with since they neither +# requiring decrypting nor specifying the oauth2 client id separately. +# +# If the password arg ends in .json, it will assume this new json method, otherwise it +# will fallback to the "oauth client id;.p12" format it was previously using. +sub xoauth2 +{ + require JSON::WebToken ; + require LWP::UserAgent ; + require HTML::Entities ; + require JSON ; + require JSON::WebToken::Crypt::RSA ; + require Crypt::OpenSSL::PKCS12 ; + require Crypt::OpenSSL::RSA ; + require Encode::Byte ; + require IO::Socket::SSL ; + + my $code = shift; + my $imap = shift; + + my ($iss,$key); + + if( $imap->Password =~ /^(.*\.json)$/x ) + { + my $json = JSON->new( ) ; + my $filename = $1; + $sync->{ debug } and myprint( "XOAUTH2 json file: $filename\n" ) ; + my $FILE ; + if ( ! open( $FILE, '<', $filename ) ) + { + $sync->{nb_errors}++ ; + exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, + "error [$filename]: $OS_ERROR\n" + ) ; + } + my $jsonfile = $json->decode( join q{}, <$FILE> ) ; + close $FILE ; + + $iss = $jsonfile->{client_id}; + $key = $jsonfile->{private_key}; + $sync->{ debug } and myprint( "Service account: $iss\n"); + $sync->{ debug } and myprint( "Private key:\n$key\n"); + } + else + { + # Get iss (service account address), keyfile name, and keypassword if necessary + ( $iss, my $keyfile, my $keypass ) = $imap->Password =~ /([\-\d\w\@\.]+);([a-zA-Z0-9 \_\-\.\/]+);?(.*)?/x ; + + # Assume key password is google default if not provided + $keypass = 'notasecret' if not $keypass; + + $sync->{ debug } and myprint( "Service account: $iss\nKey file: $keyfile\nKey password: $keypass\n"); + + # Get private key from p12 file + my $pkcs12 = Crypt::OpenSSL::PKCS12->new_from_file($keyfile); + $key = $pkcs12->private_key($keypass); + + $sync->{ debug } and myprint( "Private key:\n$key\n"); + } + + # Create jwt of oauth2 request + my $time = time ; + my $jwt = JSON::WebToken->encode( { + 'iss' => $iss, # service account + 'scope' => 'https://mail.google.com/', + 'aud' => 'https://www.googleapis.com/oauth2/v3/token', + 'exp' => $time + $DEFAULT_EXPIRATION_TIME_OAUTH2_PK12, + 'iat' => $time, + 'prn' => $imap->User # user to auth as + }, + $key, 'RS256', {'typ' => 'JWT'} ); # Crypt::OpenSSL::RSA needed here. + + # Post oauth2 request + my $ua = LWP::UserAgent->new( ) ; + $ua->env_proxy( ) ; + + my $response = $ua->post('https://www.googleapis.com/oauth2/v3/token', + { grant_type => HTML::Entities::encode_entities('urn:ietf:params:oauth:grant-type:jwt-bearer'), + assertion => $jwt } ) ; + + unless( $response->is_success( ) ) { + $sync->{nb_errors}++ ; + exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, + $response->code, "\n", $response->content, "\n" + ) ; + }else{ + $sync->{ debug } and myprint( $response->content ) ; + } + + # access_token in response is what we need + my $data = JSON::decode_json( $response->content ) ; + + # format as oauth2 auth data + my $xoauth2_string = encode_base64( 'user=' . $imap->User . "\1auth=Bearer " . $data->{access_token} . "\1\1", q{} ) ; + + $sync->{ debug } and myprint( "XOAUTH2 String: $xoauth2_string\n"); + return($xoauth2_string); +} + + + + +sub xmasterauth +{ + # This is Kerio auth admin + # This code comes from + # https://github.com/imapsync/imapsync/pull/53/files + + my $imap = shift @ARG ; + + my $user = $imap->User( ) ; + my $password = $imap->Password( ) ; + my $authmech = 'X-MASTERAUTH' ; + + my @challenge = $imap->tag_and_run( $authmech, "+" ) ; + if ( not defined $challenge[0] ) + { + $sync->{nb_errors}++ ; + exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, + "Failure authenticate with $authmech: ", + $imap->LastError, "\n" + ) ; + return ; # hahaha! + } + $sync->{ debug } and myprint( "X-MASTERAUTH challenge: [@challenge]\n" ) ; + + $challenge[1] =~ s/^\+ |^\s+|\s+$//g ; + if ( ! $imap->_imap_command( { addcrlf => 1, addtag => 0, tag => $imap->Count }, md5_hex( $challenge[1] . $password ) ) ) + { + $sync->{nb_errors}++ ; + exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, + "Failure authenticate with $authmech: ", + $imap->LastError, "\n" + ) ; + } + + if ( ! $imap->tag_and_run( 'X-SETUSER ' . $user ) ) + { + $sync->{nb_errors}++ ; + exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, + "Failure authenticate with $authmech: ", + "X-SETUSER ", $imap->LastError, "\n" + ) ; + } + + $imap->State( Mail::IMAPClient::Authenticated ) ; + # I comment this state because "Selected" state is usually done by SELECT or EXAMINE imap commands + # $imap->State( Mail::IMAPClient::Selected ) ; + + return ; +} + +sub keepalive1 +{ + my $mysync = shift @ARG ; + + $mysync->{ acc1 }->{ keepalive } = defined $mysync->{ acc1 }->{ keepalive } ? $mysync->{ acc1 }->{ keepalive } : 1 ; + + if ( $mysync->{ acc1 }->{ keepalive } ) + { + myprint( "Host1: imap connection keepalive is on on host1. Use --nokeepalive1 to disable it.\n" ) ; + } + else + { + myprint( "Host1: imap connection keepalive is off on host1. Use --keepalive1 to enable it.\n" ) ; + } + + return ; +} + +sub keepalive2 +{ + my $mysync = shift @ARG ; + + $mysync->{ acc2 }->{ keepalive } = defined $mysync->{ acc2 }->{ keepalive } ? $mysync->{ acc2 }->{ keepalive } : 1 ; + + if ( $mysync->{ acc2 }->{ keepalive } ) + { + myprint( "Host2: imap connection keepalive is on on host2. Use --nokeepalive2 to disable it.\n" ) ; + } + else + { + myprint( "Host2: imap connection keepalive is off on host2. Use --keepalive2 to enable it.\n" ) ; + } + + return ; +} + + + +sub banner_imapsync +{ + my $mysync = shift @ARG ; + my @argv = @ARG ; + + my $banner_imapsync = join q{}, + q{$RCSfile: imapsync,v $ }, + q{$Revision: 2.229 $ }, + q{$Date: 2022/09/14 18:08:24 $ }, + "\n", + "Command line used, run by $EXECUTABLE_NAME:\n", + "$PROGRAM_NAME ", command_line_nopassword( $mysync, @argv ), "\n" ; + + return( $banner_imapsync ) ; +} + +sub tests_do_valid_directory +{ + note( 'Entering tests_do_valid_directory()' ) ; + + is( 1, do_valid_directory( '.'), 'do_valid_directory: . good' ) ; + is( 1, do_valid_directory( './W/tmp/tests/valid/sub'), 'do_valid_directory: ./W/tmp/tests/valid/sub good' ) ; + + Readonly my $NB_UNIX_tests_do_valid_directory_non_root => 2 ; + diag( "OSNAME=$OSNAME EFFECTIVE_USER_ID=$EFFECTIVE_USER_ID" ) ; + + SKIP: { + skip( 'Tests only for non roor user', $NB_UNIX_tests_do_valid_directory_non_root ) if ( '0' eq $EFFECTIVE_USER_ID ) ; + diag( 'The "Error / is not writable" is on purpose' ) ; + ok( 0 == do_valid_directory( '/'), 'do_valid_directory: / bad' ) ; + diag( 'The "Error permission denied" on /noway is on purpose' ) ; + ok( 0 == do_valid_directory( '/noway'), 'do_valid_directory: /noway bad' ) ; + } + + + note( 'Leaving tests_do_valid_directory()' ) ; + return ; +} + +sub do_valid_directory +{ + my $dir = shift @ARG ; + + # all good => return ok. + return( 1 ) if ( -d $dir and -r _ and -w _ ) ; + + # exist but bad + if ( -e $dir and not -d _ ) { + myprint( "Error: $dir exists but is not a directory\n" ) ; + return( 0 ) ; + } + if ( -e $dir and not -w _ ) { + my $sb = stat $dir ; + myprintf( "Error: directory %s is not writable for user %s, permissions are %04o and owner is %s ( uid %s )\n", + $dir, getpwuid_any_os( $EFFECTIVE_USER_ID ), ($sb->mode & oct($PERMISSION_FILTER) ), getpwuid_any_os( $sb->uid ), $sb->uid( ) ) ; + return( 0 ) ; + } + # Trying to create it + myprint( "Creating directory $dir (current directory is " . getcwd( ) . ")\n" ) ; + if ( ! eval { mkpath( $dir ) } ) { + myprint( "$EVAL_ERROR" ) if ( $EVAL_ERROR ) ; + } + return( 1 ) if ( -d $dir and -r _ and -w _ ) ; + return( 0 ) ; +} + + +sub tests_match_a_pid_number +{ + note( 'Entering tests_match_a_pid_number()' ) ; + + is( undef, match_a_pid_number( ), 'match_a_pid_number: no args => undef' ) ; + is( undef, match_a_pid_number( q{} ), 'match_a_pid_number: "" => undef' ) ; + is( undef, match_a_pid_number( 'lalala' ), 'match_a_pid_number: lalala => undef' ) ; + is( 1, match_a_pid_number( 1 ), 'match_a_pid_number: 1 => 1' ) ; + is( 1, match_a_pid_number( 123 ), 'match_a_pid_number: 123 => 1' ) ; + is( 1, match_a_pid_number( -123 ), 'match_a_pid_number: -123 => 1' ) ; + is( 1, match_a_pid_number( '123' ), 'match_a_pid_number: "123" => 1' ) ; + is( 1, match_a_pid_number( '-123' ), 'match_a_pid_number: "-123" => 1' ) ; + is( undef, match_a_pid_number( 'a123' ), 'match_a_pid_number: a123 => undef' ) ; + is( undef, match_a_pid_number( '-a123' ), 'match_a_pid_number: -a123 => undef' ) ; + is( 1, match_a_pid_number( 99999 ), 'match_a_pid_number: 99999 => 1' ) ; + is( 1, match_a_pid_number( -99999 ), 'match_a_pid_number: -99999 => 1' ) ; + is( undef, match_a_pid_number( 0 ), 'match_a_pid_number: 0 => undef' ) ; + is( 1, match_a_pid_number( 100000 ), 'match_a_pid_number: 100000 => 1' ) ; + is( 1, match_a_pid_number( 123456 ), 'match_a_pid_number: 123456 => 1' ) ; + is( undef, match_a_pid_number( '-0' ), 'match_a_pid_number: "-0" => undef' ) ; + is( 1, match_a_pid_number( -100000 ), 'match_a_pid_number: -100000 => 1' ) ; + is( 1, match_a_pid_number( -123456 ), 'match_a_pid_number: -123456 => 1' ) ; + is( 1, match_a_pid_number( 2**22 ), 'match_a_pid_number: 2**22 => 1' ) ; + is( undef, match_a_pid_number( 2**22 + 1 ), 'match_a_pid_number: 2**22 + 1 => undef' ) ; + is( undef, match_a_pid_number( 4194304 + 1 ), 'match_a_pid_number: 2**22 + 1 = 4194305 => undef' ) ; + + note( 'Leaving tests_match_a_pid_number()' ) ; + return ; +} + +sub match_a_pid_number +{ + my $pid = shift @ARG ; + if ( ! defined $pid ) { return ; } + #print "$pid\n" ; + if ( ! match( $pid, '^-?\d+$' ) ) { return ; } + #print "$pid\n" ; + # can be negative on Windows + #if ( 0 > $pid ) { return ; } + #if ( 65535 < $pid ) { return ; } + if ( 2**22 < abs( $pid ) ) { return ; } + if ( 0 == abs( $pid ) ) { return ; } + return 1 ; +} + +sub tests_remove_pidfile_not_running +{ + note( 'Entering tests_remove_pidfile_not_running()' ) ; + + ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'remove_pidfile_not_running: mkpath W/tmp/tests/' ) ; + is( undef, remove_pidfile_not_running( ), 'remove_pidfile_not_running: no args => undef' ) ; + is( undef, remove_pidfile_not_running( './W' ), 'remove_pidfile_not_running: a dir => undef' ) ; + is( undef, remove_pidfile_not_running( 'noexists' ), 'remove_pidfile_not_running: noexists => undef' ) ; + is( 1, touch( 'W/tmp/tests/empty.pid' ), 'remove_pidfile_not_running: prepa empty W/tmp/tests/empty.pid' ) ; + is( undef, remove_pidfile_not_running( 'W/tmp/tests/empty.pid' ), 'remove_pidfile_not_running: W/tmp/tests/empty.pid => undef' ) ; + is( 'lalala', string_to_file( 'lalala', 'W/tmp/tests/lalala.pid' ), 'remove_pidfile_not_running: prepa W/tmp/tests/lalala.pid' ) ; + is( undef, remove_pidfile_not_running( 'W/tmp/tests/lalala.pid' ), 'remove_pidfile_not_running: W/tmp/tests/lalala.pid => undef' ) ; + is( '55555', string_to_file( '55555', 'W/tmp/tests/notrunning.pid' ), 'remove_pidfile_not_running: prepa W/tmp/tests/notrunning.pid' ) ; + is( 1, remove_pidfile_not_running( 'W/tmp/tests/notrunning.pid' ), 'remove_pidfile_not_running: W/tmp/tests/notrunning.pid => 1' ) ; + is( $PROCESS_ID, string_to_file( $PROCESS_ID, 'W/tmp/tests/running.pid' ), 'remove_pidfile_not_running: prepa W/tmp/tests/running.pid' ) ; + is( undef, remove_pidfile_not_running( 'W/tmp/tests/running.pid' ), 'remove_pidfile_not_running: W/tmp/tests/running.pid => undef' ) ; + + note( 'Leaving tests_remove_pidfile_not_running()' ) ; + return ; +} + +sub remove_pidfile_not_running +{ + # + my $pid_filename = shift @ARG ; + + #myprint( "In remove_pidfile_not_running $pid_filename\n" ) ; + if ( ! $pid_filename ) { myprint( "No variable pid_filename\n" ) ; return } ; + if ( ! -e $pid_filename ) + { + myprint( "File $pid_filename does not exist\n" ) ; + return ; + } + #myprint( "Still In remove_pidfile_not_running $pid_filename\n" ) ; + + if ( ! -f $pid_filename ) { myprint( "File $pid_filename is not a file\n" ) ; return } ; + + my $pid = firstline( $pid_filename ) ; + if ( ! match_a_pid_number( $pid ) ) { myprint( "In remove_pidfile_not_running: pid $pid in $pid_filename is not a pid number\n" ) ; return } ; + # can't kill myself => do nothing + if ( ! kill 'ZERO', $PROCESS_ID ) { myprint( "Can not kill ZERO myself $PROCESS_ID\n" ) ; return } ; + + # can't kill ZERO the pid => it is gone or own by another user => remove pidfile + if ( ! kill 'ZERO', $pid ) { + myprint( "Removing old $pid_filename since its PID $pid is not running anymore (oo-killed?)\n" ) ; + if ( unlink $pid_filename ) { + myprint( "Removed old $pid_filename\n" ) ; + return 1 ; + }else{ + myprint( "Could not remove old $pid_filename because $!\n" ) ; + return ; + } + } + myprint( "Another imapsync process $pid is running as says pidfile $pid_filename\n" ) ; + return ; +} + + +sub tests_tail +{ + note( 'Entering tests_tail()' ) ; + + ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'tail: mkpath W/tmp/tests/' ) ; + ok( ( ! -e 'W/tmp/tests/tail.pid' || unlink 'W/tmp/tests/tail.pid' ), 'tail: unlink W/tmp/tests/tail.pid' ) ; + ok( ( ! -e 'W/tmp/tests/tail.txt' || unlink 'W/tmp/tests/tail.txt' ), 'tail: unlink W/tmp/tests/tail.txt' ) ; + + is( undef, tail( ), 'tail: no args => undef' ) ; + my $mysync ; + is( undef, tail( $mysync ), 'tail: no pidfile => undef' ) ; + + $mysync->{pidfile} = 'W/tmp/tests/tail.pid' ; + is( undef, tail( $mysync ), 'tail: no pidfilelocking => undef' ) ; + + $mysync->{pidfilelocking} = 1 ; + is( undef, tail( $mysync ), 'tail: pidfile no exists => undef' ) ; + + + my $pidandlog = "33333\nW/tmp/tests/tail.txt\n" ; + is( $pidandlog, string_to_file( $pidandlog, $mysync->{pidfile} ), 'tail: put pid 33333 and tail.txt in pidfile' ) ; + is( undef, tail( $mysync ), 'tail: logfile to tail no exists => undef' ) ; + + my $tailcontent = "L1\nL2\nL3\nL4\nL5\n" ; + is( $tailcontent, string_to_file( $tailcontent, 'W/tmp/tests/tail.txt' ), + 'tail: put L1\nL2\nL3\nL4\nL5\n in W/tmp/tests/tail.txt' ) ; + + is( undef, tail( $mysync ), 'tail: fake pid in pidfile + tail off => 1' ) ; + + $mysync->{ tail } = 1 ; + is( 1, tail( $mysync ), 'tail: fake pid in pidfile + tail on=> 1' ) ; + + # put my own pid, won't do tail + $pidandlog = "$PROCESS_ID\nW/tmp/tests/tail.txt\n" ; + is( $pidandlog, string_to_file( $pidandlog, $mysync->{pidfile} ), 'tail: put my own PID in pidfile' ) ; + is( undef, tail( $mysync ), 'tail: my own pid in pidfile => undef' ) ; + + note( 'Leaving tests_tail()' ) ; + return ; +} + + + +sub tail +{ + # return undef on failures + # return 1 on success + + my $mysync = shift @ARG ; + + # no tail when aborting! + if ( $mysync->{ abort } ) { return ; } + + my $pidfile = $mysync->{pidfile} ; + my $lock = $mysync->{pidfilelocking} ; + my $tail = $mysync->{tail} ; + + if ( ! $pidfile ) { return ; } + if ( ! $lock ) { return ; } + if ( ! $tail ) { return ; } + + if ( ! -e $pidfile ) { return ; } + + my $pidtotail = firstline( $pidfile ) ; + if ( ! $pidtotail ) { return ; } + + + + # It should not happen but who knows... + if ( $pidtotail eq $PROCESS_ID ) { return ; } + + + my $filetotail = secondline( $pidfile ) ; + if ( ! $filetotail ) { return ; } + + if ( ! -r $filetotail ) + { + #myprint( "Error: can not read $filetotail\n" ) ; + return ; + } + + myprint( "Doing a tail -f on $filetotail for processus pid $pidtotail until it is finished.\n" ) ; + my $file = File::Tail->new( + name => $filetotail, + nowait => 1, + interval => 1, + tail => 1, + adjustafter => 2 + ); + + my $moretimes = 200 ; + # print one line at least + my $line = $file->read ; + myprint( $line ) ; + while ( isrunning( $pidtotail, \$moretimes ) and defined( $line = $file->read ) ) + { + myprint( $line ); + sleep( 0.02 ) ; + } + + return 1 ; +} + +sub isrunning +{ + my $pidtocheck = shift @ARG ; + my $moretimes_ref = shift @ARG ; + + if ( kill 'ZERO', $pidtocheck ) + { + #myprint( "$pidtocheck running\n" ) ; + return 1 ; + } + elsif ( $$moretimes_ref >= 0 ) + { + # continue to consider it running + $$moretimes_ref-- ; + return 1 ; + } + else + { + myprint( "Tailed processus $pidtocheck ended\n" ) ; + return ; + } +} + +sub tests_write_pidfile +{ + note( 'Entering tests_write_pidfile()' ) ; + + my $mysync ; + + is( 1, write_pidfile( ), 'write_pidfile: no args => 1' ) ; + + # no pidfile => ok + $mysync->{pidfile} = q{} ; + is( 1, write_pidfile( $mysync ), 'write_pidfile: no pidfile => undef' ) ; + + # The pidfile path is bad => failure + $mysync->{pidfile} = '/no/no/no.pid' ; + is( undef, write_pidfile( $mysync ), 'write_pidfile: no permission for /no/no/no.pid, no lock => undef' ) ; + + $mysync->{pidfilelocking} = 1 ; + is( undef, write_pidfile( $mysync ), 'write_pidfile: no permission for /no/no/no.pid + lock => undef' ) ; + + $mysync->{pidfile} = 'W/tmp/tests/test.pid' ; + ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'write_pidfile: mkpath W/tmp/tests/' ) ; + is( 1, touch( $mysync->{pidfile} ), 'write_pidfile: lock prepa' ) ; + + $mysync->{pidfilelocking} = 0 ; + is( 1, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + no lock => 1' ) ; + is( $PROCESS_ID, firstline( 'W/tmp/tests/test.pid' ), "write_pidfile: W/tmp/tests/test.pid contains $PROCESS_ID" ) ; + is( q{}, secondline( 'W/tmp/tests/test.pid' ), "write_pidfile: W/tmp/tests/test.pid contains no second line" ) ; + + $mysync->{pidfilelocking} = 1 ; + is( undef, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + lock => undef' ) ; + + + $mysync->{pidfilelocking} = 0 ; + $mysync->{ logfile } = 'rrrr.txt' ; + is( 1, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + no lock + logfile => 1' ) ; + is( $PROCESS_ID, firstline( 'W/tmp/tests/test.pid' ), "write_pidfile: + no lock + logfile W/tmp/tests/test.pid contains $PROCESS_ID" ) ; + is( q{rrrr.txt}, secondline( 'W/tmp/tests/test.pid' ), "write_pidfile: + no lock + logfile W/tmp/tests/test.pid contains rrrr.txt" ) ; + + + note( 'Leaving tests_write_pidfile()' ) ; + return ; +} + + + +sub write_pidfile +{ + # returns undef if something is considered fatal + # returns 1 otherwise + + #myprint( "In write_pidfile\n" ) ; + if ( ! @ARG ) { return 1 ; } + + my $mysync = shift @ARG ; + + # Do not write the pid file if the current process goal is to abort the process designed by the pid file + if ( $mysync->{ abort } ) { return 1 ; } + + # + my $pid_filename = $mysync->{ pidfile } ; + my $lock = $mysync->{ pidfilelocking } ; + + if ( ! $pid_filename ) + { + myprint( "PID file is unset ( to set it, use --pidfile filepath ; to avoid it use --pidfile \"\" )\n" ) ; + return( 1 ) ; + } + + myprint( "PID file is $pid_filename ( to change it, use --pidfile filepath ; to avoid it use --pidfile \"\" )\n" ) ; + if ( -e $pid_filename and $lock ) { + myprint( "$pid_filename already exists, another imapsync may be curently running. Aborting imapsync.\n" ) ; + return ; + + } + + if ( -e $pid_filename ) { + myprint( "$pid_filename already exists, overwriting it ( use --pidfilelocking to avoid concurrent runs )\n" ) ; + } + + my $pid_string = "$PROCESS_ID\n" ; + my $pid_message = "Writing my PID $PROCESS_ID in $pid_filename\n" ; + + if ( $mysync->{ logfile } ) + { + $pid_string .= "$mysync->{ logfile }\n" ; + $pid_message .= "Writing also my logfile name in $pid_filename : $mysync->{ logfile }\n" ; + } + + if ( open my $FILE_HANDLE, '>', $pid_filename ) { + myprint( $pid_message ) ; + print $FILE_HANDLE $pid_string ; + close $FILE_HANDLE ; + return( 1 ) ; + } + else + { + myprint( "Could not open $pid_filename for writing. Check permissions or disk space: $OS_ERROR\n" ) ; + return ; + } +} + + +sub fix_Inbox_INBOX_mapping +{ + my( $h1_all, $h2_all ) = @_ ; + + my $regex = q{} ; + SWITCH: { + if ( exists $h1_all->{INBOX} and exists $h2_all->{INBOX} ) { $regex = q{} ; last SWITCH ; } ; + if ( exists $h1_all->{Inbox} and exists $h2_all->{Inbox} ) { $regex = q{} ; last SWITCH ; } ; + if ( exists $h1_all->{INBOX} and exists $h2_all->{Inbox} ) { $regex = q{s/^INBOX$/Inbox/x} ; last SWITCH ; } ; + if ( exists $h1_all->{Inbox} and exists $h2_all->{INBOX} ) { $regex = q{s/^Inbox$/INBOX/x} ; last SWITCH ; } ; + } ; + return( $regex ) ; +} + +sub tests_fix_Inbox_INBOX_mapping +{ + note( 'Entering tests_fix_Inbox_INBOX_mapping()' ) ; + + + my( $h1_all, $h2_all ) ; + + $h1_all = { 'INBOX' => q{} } ; + $h2_all = { 'INBOX' => q{} } ; + ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX INBOX' ) ; + + $h1_all = { 'Inbox' => q{} } ; + $h2_all = { 'Inbox' => q{} } ; + ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: Inbox Inbox' ) ; + + $h1_all = { 'INBOX' => q{} } ; + $h2_all = { 'Inbox' => q{} } ; + ok( q{s/^INBOX$/Inbox/x} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX Inbox' ) ; + + $h1_all = { 'Inbox' => q{} } ; + $h2_all = { 'INBOX' => q{} } ; + ok( q{s/^Inbox$/INBOX/x} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: Inbox INBOX' ) ; + + $h1_all = { 'INBOX' => q{} } ; + $h2_all = { 'rrrrr' => q{} } ; + ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX rrrrrr' ) ; + + $h1_all = { 'rrrrr' => q{} } ; + $h2_all = { 'Inbox' => q{} } ; + ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: rrrrr Inbox' ) ; + + note( 'Leaving tests_fix_Inbox_INBOX_mapping()' ) ; + return ; +} + + +sub jux_utf8_list +{ + my @s_inp = @_ ; + my $s_out = q{} ; + foreach my $s ( @s_inp ) { + $s_out .= jux_utf8( $s ) . "\n" ; + } + return( $s_out ) ; +} + +sub tests_jux_utf8_list +{ + note( 'Entering tests_jux_utf8_list()' ) ; + + use utf8 ; + is( q{}, jux_utf8_list( ), 'jux_utf8_list: void' ) ; + is( "[]\n", jux_utf8_list( q{} ), 'jux_utf8_list: empty string' ) ; + is( "[INBOX]\n", jux_utf8_list( 'INBOX' ), 'jux_utf8_list: INBOX' ) ; + is( "[&ANY-] = [Ö]\n", jux_utf8_list( '&ANY-' ), 'jux_utf8_list: [&ANY-] = [Ö]' ) ; + + note( 'Leaving tests_jux_utf8_list()' ) ; + return( 0 ) ; +} + +# editing utf8 can be tricky without an utf8 editor +sub tests_jux_utf8_old +{ + note( 'Entering tests_jux_utf8_old()' ) ; + + no utf8 ; + + is( '[]', jux_utf8_old( q{} ), 'jux_utf8_old: void => []' ) ; + is( '[INBOX]', jux_utf8_old( 'INBOX'), 'jux_utf8_old: INBOX => [INBOX]' ) ; + is( '[&ZTZO9nux-] = [收件箱]', jux_utf8_old( '&ZTZO9nux-'), 'jux_utf8_old: => [&ZTZO9nux-] = [收件箱]' ) ; + is( '[&ANY-] = [Ö]', jux_utf8_old( '&ANY-'), 'jux_utf8_old: &ANY- => [&ANY-] = [Ö]' ) ; + # +BD8EQAQ1BDQEOwQ+BDM- SHOULD stay as is! + is( '[+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]', jux_utf8_old( '+BD8EQAQ1BDQEOwQ+BDM-' ), 'jux_utf8_old: => [+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]' ) ; + is( '[&BB8EQAQ+BDUEOgRC-] = [Проект]', jux_utf8_old( '&BB8EQAQ+BDUEOgRC-' ), 'jux_utf8_old: => [&BB8EQAQ+BDUEOgRC-] = [Проект]' ) ; + + note( 'Leaving tests_jux_utf8_old()' ) ; + return ; +} + +sub jux_utf8_old +{ + # juxtapose utf8 at the right if different + my ( $s_utf7 ) = shift @ARG ; + my ( $s_utf8 ) = imap_utf7_decode_old( $s_utf7 ) ; + + if ( $s_utf7 eq $s_utf8 ) { + #myprint( "[$s_utf7]\n" ) ; + return( "[$s_utf7]" ) ; + }else{ + #myprint( "[$s_utf7] = [$s_utf8]\n" ) ; + return( "[$s_utf7] = [$s_utf8]" ) ; + } +} + +# Copied from http://cpansearch.perl.org/src/FABPOT/Unicode-IMAPUtf7-2.01/lib/Unicode/IMAPUtf7.pm +# and then fixed with +# https://rt.cpan.org/Public/Bug/Display.html?id=11172 +sub imap_utf7_decode_old +{ + my ( $s ) = shift @ARG ; + + # Algorithm + # On remplace , par / dans les BASE 64 (, entre & et -) + # On remplace les &, non suivi d'un - par + + # On remplace les &- par & + $s =~ s/&([^,&\-]*),([^,\-&]*)\-/&$1\/$2\-/xg ; + $s =~ s/&(?!\-)/\+/xg ; + $s =~ s/&\-/&/xg ; + return( Unicode::String::utf7( $s )->utf8 ) ; +} + + + + + +sub tests_jux_utf8 +{ + note( 'Entering tests_jux_utf8()' ) ; + #no utf8 ; + use utf8 ; + + #binmode STDOUT, ":encoding(UTF-8)" ; + binmode STDERR, ":encoding(UTF-8)" ; + + # This test is because the binary can fail on it, a PAR.pm issue. + # The failure was with the underlying Encode::IMAPUTF7 module line 66 release 1.05 + # Was solved by including Encode in imapsync and using "pp -x". + ok( find_encoding( "UTF-16BE"), 'jux_utf8: Encode::find_encoding: UTF-16BE' ) ; + + # + is( '[]', jux_utf8( q{} ), 'jux_utf8: void => []' ) ; + is( '[INBOX]', jux_utf8( 'INBOX'), 'jux_utf8: INBOX => [INBOX]' ) ; + is( '[&ANY-] = [Ö]', jux_utf8( '&ANY-'), 'jux_utf8: &ANY- => [&ANY-] = [Ö]' ) ; + # +BD8EQAQ1BDQEOwQ+BDM- must stay as is + is( '[+BD8EQAQ1BDQEOwQ+BDM-]', jux_utf8( '+BD8EQAQ1BDQEOwQ+BDM-' ), 'jux_utf8: => [+BD8EQAQ1BDQEOwQ+BDM-] = [+BD8EQAQ1BDQEOwQ+BDM-]' ) ; + is( '[&BB8EQAQ+BDUEOgRC-] = [Проект]', jux_utf8( '&BB8EQAQ+BDUEOgRC-' ), 'jux_utf8: => [&BB8EQAQ+BDUEOgRC-] = [Проект]' ) ; + + is( '[R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]', jux_utf8( q{R&AOk-ponses 1200+1201+1202} ), 'jux_utf8: [R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]' ) ; + my $str = Encode::IMAPUTF7::encode("IMAP-UTF-7", 'Réponses 1200+1201+1202' ) ; + is( '[R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]', jux_utf8( $str ), "jux_utf8: [$str] = [Réponses 1200+1201+1202]" ) ; + + is( '[INBOX.&AOkA4ADnAPk-&-*] = [INBOX.éàçù&*]', jux_utf8( 'INBOX.&AOkA4ADnAPk-&-*' ), "jux_utf8: [INBOX.&AOkA4ADnAPk-&-*] = [INBOX.éàçù&*]" ) ; + + is( '[&ZTZO9nux-] = [收件箱]', jux_utf8( '&ZTZO9nux-'), 'jux_utf8: => [&ZTZO9nux-] = [收件箱]' ) ; + # + # + is( '[!Old Emails]', jux_utf8( '!Old Emails'), 'jux_utf8: !Old Emails => [!Old Emails]' ) ; + is( '[2006 Budget & Fcst]', jux_utf8( '2006 Budget & Fcst'), 'jux_utf8: 2006 Budget & Fcst => [2006 Budget & Fcst]' ) ; + note( 'Leaving tests_jux_utf8()' ) ; + return ; +} + +sub jux_utf8 +{ + #use utf8 ; + # juxtapose utf8 at the right if different + my ( $s_utf7 ) = shift @ARG ; + my ( $s_utf8 ) = imap_utf7_decode( $s_utf7 ) ; + + if ( $s_utf7 eq $s_utf8 ) { + #myprint( "[$s_utf7]\n" ) ; + return( "[$s_utf7]" ) ; + }else{ + #myprint( "[$s_utf7] = [$s_utf8]\n" ) ; + return( "[$s_utf7] = [$s_utf8]" ) ; + } +} + +sub imap_utf7_decode +{ + #use utf8 ; + my ( $s ) = shift @ARG ; + return( Encode::IMAPUTF7::decode("IMAP-UTF-7", $s ) ) ; +} + +sub imap_utf7_encode +{ + #use utf8 ; + my ( $s ) = shift @ARG ; + return( Encode::IMAPUTF7::encode("IMAP-UTF-7", $s ) ) ; +} + + + +sub imap_utf7_encode_old +{ + my ( $s ) = @_ ; + + $s = Unicode::String::utf8( $s )->utf7 ; + + $s =~ s/\+([^\/&\-]*)\/([^\/\-&]*)\-/\+$1,$2\-/xg ; + $s =~ s/&/&\-/xg ; + $s =~ s/\+([^+\-]+)?\-/&$1\-/xg ; + return( $s ) ; +} + + + + +sub select_folder +{ + my ( $mysync, $imap, $folder, $hostside ) = @_ ; + if ( ! $imap->select( $folder ) ) { + my $error = join q{}, + "$hostside folder $folder: Could not select: ", + $imap->LastError, "\n" ; + errors_incr( $mysync, $error ) ; + return( 0 ) ; + }else{ + # ok select succeeded + return( 1 ) ; + } +} + +sub examine_folder +{ + my ( $mysync, $imap, $folder, $hostside ) = @_ ; + if ( ! $imap->examine( $folder ) ) { + my $error = join q{}, + "$hostside folder $folder: Could not examine: ", + $imap->LastError, "\n" ; + errors_incr( $mysync, $error ) ; + return( 0 ) ; + }else{ + # ok select succeeded + return( 1 ) ; + } +} + + +sub count_from_select +{ + my @lines = @ARG ; + my $count ; + foreach my $line ( @lines ) { + #myprint( "line = [$line]\n" ) ; + if ( $line =~ m/^\*\s+(\d+)\s+EXISTS/x ) { + $count = $1 ; + return( $count ) ; + } + } + return( undef ) ; +} + + + +sub create_folder_old +{ + my $mysync = shift @ARG ; + my( $imap, $h2_fold, $h1_fold ) = @ARG ; + + myprint( "Creating (old way) folder [$h2_fold] on host2\n" ) ; + if ( ( 'INBOX' eq uc $h2_fold ) + and ( $imap->exists( $h2_fold ) ) ) { + myprint( "Folder [$h2_fold] already exists\n" ) ; + return( 1 ) ; + } + if ( ! $mysync->{dry} ){ + if ( ! $imap->create( $h2_fold ) ) { + my $error = join q{}, + "Could not create folder [$h2_fold] from [$h1_fold]: ", + $imap->LastError( ), "\n" ; + errors_incr( $mysync, $error ) ; + # success if folder exists ("already exists" error) + return( 1 ) if $imap->exists( $h2_fold ) ; + # failure since create failed + return( 0 ) ; + }else{ + #create succeeded + myprint( "Created ( the old way ) folder [$h2_fold] on host2\n" ) ; + return( 1 ) ; + } + }else{ + # dry mode, no folder so many imap will fail, assuming failure + myprint( "Created ( the old way ) folder [$h2_fold] on host2 $mysync->{dry_message}\n" ) ; + return( 0 ) ; + } +} + + +sub create_folder +{ + my $mysync = shift @ARG ; + my( $myimap2 , $h2_fold , $h1_fold ) = @ARG ; + my( @parts , $parent ) ; + + if ( $myimap2->IsUnconnected( ) ) { + myprint( "Host2: Unconnected state\n" ) ; + return( 0 ) ; + } + + if ( $create_folder_old ) { + return( create_folder_old( $mysync, $myimap2 , $h2_fold , $h1_fold ) ) ; + } + + # $imap->exists() calls $imap->status() that does an IMAP STATUS folder + myprint( "Creating folder [$h2_fold] on host2\n" ) ; + if ( ( 'INBOX' eq uc $h2_fold ) + and ( $myimap2->exists( $h2_fold ) ) ) { + myprint( "Folder [$h2_fold] already exists\n" ) ; + return( 1 ) ; + } + + if ( $mixfolders and $myimap2->exists( $h2_fold ) ) { + myprint( "Folder [$h2_fold] already exists (--nomixfolders is not set)\n" ) ; + return( 1 ) ; + } + + + if ( ( not $mixfolders ) and ( $myimap2->exists( $h2_fold ) ) ) { + myprint( "Folder [$h2_fold] already exists and --nomixfolders is set\n" ) ; + return( 0 ) ; + } + + @parts = split /\Q$mysync->{ h2_sep }\E/x, $h2_fold ; + pop @parts ; + $parent = join $mysync->{ h2_sep }, @parts ; + $parent =~ s/^\s+|\s+$//xg ; + if ( ( $parent ne q{} ) and ( ! $myimap2->exists( $parent ) ) ) { + create_folder( $mysync, $myimap2 , $parent , $h1_fold ) ; + } + + if ( ! $mysync->{dry} ) { + if ( ! $myimap2->create( $h2_fold ) ) { + my $error = join q{}, + "Could not create folder [$h2_fold] from [$h1_fold]: " , + $myimap2->LastError( ), "\n" ; + errors_incr( $mysync, $error ) ; + # success if folder exists ("already exists" error) or selectable + if ( $myimap2->exists( $h2_fold ) or select_folder( $mysync, $myimap2, $h2_fold, 'Host2' ) ) + { + return( 1 ) ; + } + # failure since create failed + not exist + not selectable + return( 0 ) ; + }else{ + #create succeeded + myprint( "Created folder [$h2_fold] on host2\n" ) ; + return( 1 ) ; + } + }else{ + # dry mode, no folder so many imap will fail, assuming failure + myprint( "Created folder [$h2_fold] on host2 $mysync->{dry_message}\n" ) ; + if ( ! $mysync->{ justfolders } ) { + myprint( "Since --dry mode is on and folder [$h2_fold] on host2 does not exist yet, syncing messages will not be simulated.\n" + . "To simulate message syncing, use --justfolders without --dry to first create the missing folders then rerun the --dry sync.\n" ) ; + # The messages that could be transferred are counted and the number is given at the end. + } + return( 0 ) ; + } +} + + + +sub tests_folder_routines +{ + note( 'Entering tests_folder_routines()' ) ; + + ok( !is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 1' ); + ok( add_to_requested_folders('folder_foo'), 'add_to_requested_folders folder_foo' ); + ok( is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 2' ); + ok( !is_requested_folder('folder_NO_EXIST'), 'is_requested_folder folder_NO_EXIST' ); + + is_deeply( [ 'folder_foo' ], [ remove_from_requested_folders( 'folder_foo' ) ], 'removed folder_foo => folder_foo' ) ; + ok( !is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 3' ); + my @f ; + ok( @f = add_to_requested_folders('folder_bar', 'folder_toto'), "add result: @f" ); + ok( is_requested_folder('folder_bar'), 'is_requested_folder 4' ); + ok( is_requested_folder('folder_toto'), 'is_requested_folder 5' ); + ok( remove_from_requested_folders('folder_toto'), 'remove_from_requested_folders: ' ); + ok( !is_requested_folder('folder_toto'), 'is_requested_folder 6' ); + + is_deeply( [ 'folder_bar' ], [ remove_from_requested_folders('folder_bar') ], 'remove_from_requested_folders: empty' ) ; + + ok( 0 == compare_lists( [ sort_requested_folders( ) ], [] ), 'sort_requested_folders: all empty' ) ; + ok( add_to_requested_folders( 'A_99', 'M_55', 'Z_11' ), 'add_to_requested_folders M_55 Z_11' ); + ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'A_99', 'M_55', 'Z_11' ] ), 'sort_requested_folders: middle' ) ; + + + @folderfirst = ( 'Z_11' ) ; + + ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'A_99', 'M_55' ] ), 'sort_requested_folders: first+middle' ) ; + + is_deeply( [ 'Z_11', 'A_99', 'M_55' ], [ sort_requested_folders( ) ], 'sort_requested_folders: first+middle is_deeply' ) ; + + @folderlast = ( 'A_99' ) ; + ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'M_55', 'A_99' ] ), 'sort_requested_folders: first+middle+last 1' ) ; + + ok( add_to_requested_folders('M_55', 'M_44',), 'add_to_requested_folders M_55 M_44' ) ; + + ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'M_44', 'M_55', 'A_99'] ), 'sort_requested_folders: first+middle+last 2' ) ; + + + ok( add_to_requested_folders('A_88', 'Z_22',), 'add_to_requested_folders A_88 Z_22' ) ; + @folderfirst = qw( Z_22 Z_11 ) ; + @folderlast = qw( A_99 A_88 ) ; + ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_22', 'Z_11', 'M_44', 'M_55', 'A_99', 'A_88' ] ), 'sort_requested_folders: first+middle+last 3' ) ; + undef @folderfirst ; + undef @folderlast ; + + note( 'Leaving tests_folder_routines()' ) ; + return ; +} + + +sub sort_requested_folders +{ + my @requested_folders_sorted = () ; + + $sync->{ debug } and myprint "folderfirst: @folderfirst\n" ; + my @folderfirst_requested = remove_from_requested_folders( @folderfirst ) ; + #myprint "folderfirst_requested: @folderfirst_requested\n" ; + + my @folderlast_requested = remove_from_requested_folders( @folderlast ) ; + + my @middle = sort keys %requested_folder ; + + @requested_folders_sorted = ( @folderfirst_requested, @middle, @folderlast_requested ) ; + $sync->{ debug } and myprint "requested_folders_sorted: @requested_folders_sorted\n" ; + add_to_requested_folders( @requested_folders_sorted ) ; + + return( @requested_folders_sorted ) ; +} + +sub is_requested_folder +{ + my ( $folder ) = @_; + + return( defined $requested_folder{ $folder } ) ; +} + + +sub add_to_requested_folders +{ + my @wanted_folders = @_ ; + + foreach my $folder ( @wanted_folders ) { + ++$requested_folder{ $folder } ; + } + return( keys %requested_folder ) ; +} + +sub tests_remove_from_requested_folders +{ + note( 'Entering tests_remove_from_requested_folders()' ) ; + + is( undef, undef, 'remove_from_requested_folders: undef is undef' ) ; + is_deeply( [], [ remove_from_requested_folders( ) ], 'remove_from_requested_folders: no args' ) ; + %requested_folder = ( + 'F1' => 1, + ) ; + is_deeply( [], [ remove_from_requested_folders( ) ], 'remove_from_requested_folders: remove nothing among F1 => nothing' ) ; + is_deeply( [], [ remove_from_requested_folders( 'Fno' ) ], 'remove_from_requested_folders: remove Fno among F1 => nothing' ) ; + is_deeply( [ 'F1' ], [ remove_from_requested_folders( 'F1' ) ], 'remove_from_requested_folders: remove F1 among F1 => F1' ) ; + is_deeply( { }, { %requested_folder }, 'remove_from_requested_folders: remove F1 among F1 => %requested_folder emptied' ) ; + + %requested_folder = ( + 'F1' => 1, + 'F2' => 1, + ) ; + is_deeply( [], [ remove_from_requested_folders( ) ], 'remove_from_requested_folders: remove nothing among F1 F2 => nothing' ) ; + is_deeply( [], [ remove_from_requested_folders( 'Fno' ) ], 'remove_from_requested_folders: remove Fno among F1 F2 => nothing' ) ; + is_deeply( [ 'F1' ], [ remove_from_requested_folders( 'F1' ) ], 'remove_from_requested_folders: remove F1 among F1 F2 => F1' ) ; + is_deeply( { 'F2' => 1 }, { %requested_folder }, 'remove_from_requested_folders: remove F1 among F1 F2 => %requested_folder F2' ) ; + + is_deeply( [], [ remove_from_requested_folders( 'F1' ) ], 'remove_from_requested_folders: remove F1 among F2 => nothing' ) ; + is_deeply( [ 'F2' ], [ remove_from_requested_folders( 'F1', 'F2' ) ], 'remove_from_requested_folders: remove F1 F2 among F2 => F2' ) ; + is_deeply( {}, { %requested_folder }, 'remove_from_requested_folders: remove F1 among F1 F2 => %requested_folder F2' ) ; + + %requested_folder = ( + 'F1' => 1, + 'F2' => 1, + 'F3' => 1, + ) ; + is_deeply( [ 'F1', 'F2' ], [ remove_from_requested_folders( 'F1', 'F2' ) ], 'remove_from_requested_folders: remove F1 F2 among F1 F2 F3 => F1 F2' ) ; + is_deeply( { 'F3' => 1 }, { %requested_folder }, 'remove_from_requested_folders: remove F1 F2 among F1 F2 F3 => %requested_folder F3' ) ; + + undef %requested_folder ; + + note( 'Leaving tests_remove_from_requested_folders()' ) ; + return ; +} + + +sub remove_from_requested_folders +{ + my @unwanted_folders = @_ ; + + my @removed_folders = () ; + foreach my $folder ( @unwanted_folders ) { + if ( exists $requested_folder{ $folder } ) + { + delete $requested_folder{ $folder } ; + push @removed_folders, $folder ; + } + } + return( @removed_folders ) ; +} + +sub compare_lists +{ + my ($list_1_ref, $list_2_ref) = @_; + + return($MINUS_ONE) if ((not defined $list_1_ref) and defined $list_2_ref); + return(0) if ((not defined $list_1_ref) and not defined $list_2_ref); # end if no list + return(1) if (not defined $list_2_ref); # end if only one list + + if (not ref $list_1_ref ) {$list_1_ref = [$list_1_ref]}; + if (not ref $list_2_ref ) {$list_2_ref = [$list_2_ref]}; + + + my $last_used_indice = $MINUS_ONE; + + + ELEMENT: + foreach my $indice ( 0 .. $#{ $list_1_ref } ) { + $last_used_indice = $indice ; + + # End of list_2 + return 1 if ($indice > $#{ $list_2_ref } ) ; + + my $element_list_1 = $list_1_ref->[$indice] ; + my $element_list_2 = $list_2_ref->[$indice] ; + my $balance = $element_list_1 cmp $element_list_2 ; + next ELEMENT if ($balance == 0) ; + return $balance ; + } + # each element equal until last indice of list_1 + return $MINUS_ONE if ($last_used_indice < $#{ $list_2_ref } ) ; + + # same size, each element equal + return 0 ; +} + +sub tests_compare_lists +{ + note( 'Entering tests_compare_lists()' ) ; + + my $empty_list_ref = []; + + ok( 0 == compare_lists() , 'compare_lists, no args'); + ok( 0 == compare_lists(undef) , 'compare_lists, undef = nothing'); + ok( 0 == compare_lists(undef, undef) , 'compare_lists, undef = undef'); + ok($MINUS_ONE == compare_lists(undef , []) , 'compare_lists, undef < []'); + ok($MINUS_ONE == compare_lists(undef , [1]) , 'compare_lists, undef < [1]'); + ok($MINUS_ONE == compare_lists(undef , [0]) , 'compare_lists, undef < [0]'); + ok(+1 == compare_lists([]) , 'compare_lists, [] > nothing'); + ok(+1 == compare_lists([], undef) , 'compare_lists, [] > undef'); + ok( 0 == compare_lists([] , []) , 'compare_lists, [] = []'); + + ok($MINUS_ONE == compare_lists([] , [1]) , 'compare_lists, [] < [1]'); + ok(+1 == compare_lists([1] , []) , 'compare_lists, [1] > []'); + + + ok( 0 == compare_lists( [1], 1 ) , 'compare_lists, [1] = 1 ') ; + ok( 0 == compare_lists( 1 , [1] ) , 'compare_lists, 1 = [1]') ; + ok( 0 == compare_lists( 1 , 1 ) , 'compare_lists, 1 = 1 ') ; + ok( $MINUS_ONE == compare_lists( 0 , 1 ) , 'compare_lists, 0 < 1 ') ; + ok( $MINUS_ONE == compare_lists( $MINUS_ONE , 0 ) , 'compare_lists, -1 < 0 ') ; + ok( $MINUS_ONE == compare_lists( 1 , 2 ) , 'compare_lists, 1 < 2 ') ; + ok( +1 == compare_lists( 2 , 1 ) , 'compare_lists, 2 > 1 ') ; + + + ok( 0 == compare_lists([1,2], [1,2]) , 'compare_lists, [1,2] = [1,2]' ) ; + ok($MINUS_ONE == compare_lists([1], [1,2]) , 'compare_lists, [1] < [1,2]' ) ; + ok(+1 == compare_lists([2], [1,2]) , 'compare_lists, [2] > [1,2]' ) ; + ok($MINUS_ONE == compare_lists([1], [1,1]) , 'compare_lists, [1] < [1,1]' ) ; + ok(+1 == compare_lists([1, 1], [1]) , 'compare_lists, [1, 1] > [1]' ) ; + ok( 0 == compare_lists([1 .. $NUMBER_20_000] , [1 .. $NUMBER_20_000]) + , 'compare_lists, [1..20_000] = [1..20_000]' ) ; + ok($MINUS_ONE == compare_lists([1], [2]) , 'compare_lists, [1] < [2]') ; + ok( 0 == compare_lists([2], [2]) , 'compare_lists, [0] = [2]') ; + ok(+1 == compare_lists([2], [1]) , 'compare_lists, [2] > [1]') ; + + ok($MINUS_ONE == compare_lists(['a'], ['b']) , 'compare_lists, ["a"] < ["b"]') ; + ok( 0 == compare_lists(['a'], ['a']) , 'compare_lists, ["a"] = ["a"]') ; + ok( 0 == compare_lists(['ab'], ['ab']) , 'compare_lists, ["ab"] = ["ab"]') ; + ok(+1 == compare_lists(['b'], ['a']) , 'compare_lists, ["b"] > ["a"]') ; + ok($MINUS_ONE == compare_lists(['a'], ['aa']) , 'compare_lists, ["a"] < ["aa"]') ; + ok($MINUS_ONE == compare_lists(['a'], ['a', 'a']), 'compare_lists, ["a"] < ["a", "a"]') ; + ok( 0 == compare_lists([split q{ }, 'a b' ], ['a', 'b']), 'compare_lists, split') ; + ok( 0 == compare_lists([sort split q{ }, 'b a' ], ['a', 'b']), 'compare_lists, sort split') ; + + note( 'Leaving tests_compare_lists()' ) ; + return ; +} + + +sub guess_prefix +{ + my @foldernames = @_ ; + + my $prefix_guessed = q{} ; + foreach my $folder ( @foldernames ) { + next if ( $folder =~ m{^INBOX$}xi ) ; # no guessing from INBOX + if ( $folder !~ m{^INBOX}xi ) { + $prefix_guessed = q{} ; # prefix empty guessed + last ; + } + if ( $folder =~ m{^(INBOX(?:\.|\/))}xi ) { + $prefix_guessed = $1 ; # prefix Inbox/ or INBOX. guessed + } + } + return( $prefix_guessed ) ; +} + +sub tests_guess_prefix +{ + note( 'Entering tests_guess_prefix()' ) ; + + is( guess_prefix( ), q{}, 'guess_prefix: no args => empty string' ) ; + is( q{} , guess_prefix( 'INBOX' ), 'guess_prefix: INBOX alone' ) ; + is( q{} , guess_prefix( 'Inbox' ), 'guess_prefix: Inbox alone' ) ; + is( q{} , guess_prefix( 'INBOX' ), 'guess_prefix: INBOX alone' ) ; + is( 'INBOX/' , guess_prefix( 'INBOX', 'INBOX/Junk' ), 'guess_prefix: INBOX INBOX/Junk' ) ; + is( 'INBOX.' , guess_prefix( 'INBOX', 'INBOX.Junk' ), 'guess_prefix: INBOX INBOX.Junk' ) ; + is( 'Inbox/' , guess_prefix( 'Inbox', 'Inbox/Junk' ), 'guess_prefix: Inbox Inbox/Junk' ) ; + is( 'Inbox.' , guess_prefix( 'Inbox', 'Inbox.Junk' ), 'guess_prefix: Inbox Inbox.Junk' ) ; + is( 'INBOX/' , guess_prefix( 'INBOX', 'INBOX/Junk', 'INBOX/rrr' ), 'guess_prefix: INBOX INBOX/Junk INBOX/rrr' ) ; + is( q{} , guess_prefix( 'INBOX', 'INBOX/Junk', 'INBOX/rrr', 'zzz' ), 'guess_prefix: INBOX INBOX/Junk INBOX/rrr zzz' ) ; + is( q{} , guess_prefix( 'INBOX', 'Junk' ), 'guess_prefix: INBOX Junk' ) ; + is( q{} , guess_prefix( 'INBOX', 'Junk' ), 'guess_prefix: INBOX Junk' ) ; + + note( 'Leaving tests_guess_prefix()' ) ; + return ; +} + +sub get_prefix +{ + my( $imap, $prefix_in, $prefix_opt, $Side, $folders_ref ) = @_ ; + my( $prefix_out, $prefix_guessed ) ; + + ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: Getting prefix\n" ) ; + $prefix_guessed = guess_prefix( @{ $folders_ref } ) ; + myprint( "$Side: guessing prefix from folder listing: [$prefix_guessed]\n" ) ; + ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: Calling namespace capability\n" ) ; + if ( $imap->has_capability( 'namespace' ) ) { + my $r_namespace = $imap->namespace( ) ; + $prefix_out = $r_namespace->[0][0][0] ; + myprint( "$Side: prefix given by NAMESPACE: [$prefix_out]\n" ) ; + if ( defined $prefix_in ) { + myprint( "$Side: but using [$prefix_in] given by $prefix_opt\n" ) ; + $prefix_out = $prefix_in ; + return( $prefix_out ) ; + }else{ + # all good + return( $prefix_out ) ; + } + } + else{ + if ( defined $prefix_in ) { + myprint( "$Side: using [$prefix_in] given by $prefix_opt\n" ) ; + $prefix_out = $prefix_in ; + return( $prefix_out ) ; + }else{ + myprint( + "$Side: No NAMESPACE capability so using guessed prefix [$prefix_guessed]\n", + help_to_guess_prefix( $imap, $prefix_opt ) ) ; + return( $prefix_guessed ) ; + } + } + return ; +} + + +sub guess_separator +{ + my @foldernames = @_ ; + + #return( undef ) unless ( @foldernames ) ; + + my $sep_guessed ; + my %counter ; + foreach my $folder ( @foldernames ) { + $counter{'/'}++ while ( $folder =~ m{/}xg ) ; # count / + $counter{'.'}++ while ( $folder =~ m{\.}xg ) ; # count . + $counter{'\\\\'}++ while ( $folder =~ m{(\\){2}}xg ) ; # count \\ + $counter{'\\'}++ while ( $folder =~ m{[^\\](\\){1}(?=[^\\])}xg ) ; # count \ + } + my @race_sorted = sort { $counter{ $b } <=> $counter{ $a } } keys %counter ; + $sync->{ debug } and myprint( "@foldernames\n@race_sorted\n", %counter, "\n" ) ; + $sep_guessed = shift @race_sorted || $LAST_RESSORT_SEPARATOR ; # / when nothing found. + return( $sep_guessed ) ; +} + +sub tests_guess_separator +{ + note( 'Entering tests_guess_separator()' ) ; + + ok( '/' eq guess_separator( ), 'guess_separator: no args' ) ; + ok( '/' eq guess_separator( 'abcd' ), 'guess_separator: abcd' ) ; + ok( '/' eq guess_separator( 'a/b/c.d' ), 'guess_separator: a/b/c.d' ) ; + ok( '.' eq guess_separator( 'a.b/c.d' ), 'guess_separator: a.b/c.d' ) ; + ok( '\\\\' eq guess_separator( 'a\\\\b\\\\c.c\\\\d/e/f' ), 'guess_separator: a\\\\b\\\\c.c\\\\d/e/f' ) ; + ok( '\\' eq guess_separator( 'a\\b\\c.c\\d/e/f' ), 'guess_separator: a\\b\\c.c\\d/e/f' ) ; + ok( '\\' eq guess_separator( 'a\\b' ), 'guess_separator: a\\b' ) ; + ok( '\\' eq guess_separator( 'a\\b\\c' ), 'guess_separator: a\\b\\c' ) ; + + note( 'Leaving tests_guess_separator()' ) ; + return ; +} + +sub get_separator +{ + my( $imap, $sep_in, $sep_opt, $Side, $folders_ref ) = @_ ; + my( $sep_out, $sep_guessed ) ; + + ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: Getting separator\n" ) ; + $sep_guessed = guess_separator( @{ $folders_ref } ) ; + myprint( "$Side: guessing separator from folder listing: [$sep_guessed]\n" ) ; + + ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: calling namespace capability\n" ) ; + if ( $imap->has_capability( 'namespace' ) ) + { + $sep_out = $imap->separator( ) ; + if ( defined $sep_out ) { + myprint( "$Side: separator given by NAMESPACE: [$sep_out]\n" ) ; + if ( defined $sep_in ) { + myprint( "$Side: but using [$sep_in] given by $sep_opt\n" ) ; + $sep_out = $sep_in ; + return( $sep_out ) ; + }else{ + return( $sep_out ) ; + } + }else{ + if ( defined $sep_in ) { + myprint( "$Side: NAMESPACE request failed but using [$sep_in] given by $sep_opt\n" ) ; + $sep_out = $sep_in ; + return( $sep_out ) ; + }else{ + myprint( + "$Side: NAMESPACE request failed so using guessed separator [$sep_guessed]\n", + help_to_guess_sep( $imap, $sep_opt ) ) ; + return( $sep_guessed ) ; + } + } + } + else + { + if ( defined $sep_in ) { + myprint( "$Side: No NAMESPACE capability but using [$sep_in] given by $sep_opt\n" ) ; + $sep_out = $sep_in ; + return( $sep_out ) ; + }else{ + myprint( + "$Side: No NAMESPACE capability, so using guessed separator [$sep_guessed]\n", + help_to_guess_sep( $imap, $sep_opt ) ) ; + return( $sep_guessed ) ; + } + } + return ; +} + +sub help_to_guess_sep +{ + my( $imap, $sep_opt ) = @_ ; + + my $help_to_guess_sep = "You can set the separator character with the $sep_opt option,\n" + . "the complete listing of folders may help you to find it\n" + . folders_list_to_help( $imap ) ; + + return( $help_to_guess_sep ) ; +} + +sub help_to_guess_prefix +{ + my( $imap, $prefix_opt ) = @_ ; + + my $help_to_guess_prefix = "You can set the prefix namespace with the $prefix_opt option,\n" + . "the folowing listing of folders may help you to find it:\n" + . folders_list_to_help( $imap ) ; + + return( $help_to_guess_prefix ) ; +} + + +sub folders_list_to_help +{ + my( $imap ) = shift @ARG ; + + my @folders = $imap->folders ; + my $listing = join q{}, map { "[$_]\n" } @folders ; + return( $listing ) ; +} + +# Globals are $sync @h1_folders_all @h2_folders_all $prefix1 $prefix2 +sub private_folders_separators_and_prefixes +{ +# what are the private folders separators and prefixes for each server ? + + ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "Getting separators\n" ) ; + $sync->{ h1_sep } = get_separator( $sync->{imap1}, $sync->{ sep1 }, '--sep1', 'Host1', \@h1_folders_all ) ; + $sync->{ h2_sep } = get_separator( $sync->{imap2}, $sync->{ sep2 }, '--sep2', 'Host2', \@h2_folders_all ) ; + + + $sync->{ h1_prefix } = get_prefix( $sync->{imap1}, $prefix1, '--prefix1', 'Host1', \@h1_folders_all ) ; + $sync->{ h2_prefix } = get_prefix( $sync->{imap2}, $prefix2, '--prefix2', 'Host2', \@h2_folders_all ) ; + + myprint( "Host1: separator and prefix: [$sync->{ h1_sep }][$sync->{ h1_prefix }]\n" ) ; + myprint( "Host2: separator and prefix: [$sync->{ h2_sep }][$sync->{ h2_prefix }]\n" ) ; + return ; +} + + +sub subfolder1 +{ + my $mysync = shift @ARG ; + my $subfolder1 = sanitize_subfolder( $mysync->{ subfolder1 } ) ; + + if ( $subfolder1 ) + { + # turns off automap + myprint( "Turning off automapping folders because of --subfolder1\n" ) ; + $mysync->{ automap } = undef ; + myprint( "Sanitizing subfolder1: [$mysync->{ subfolder1 }] => [$subfolder1]\n" ) ; + $mysync->{ subfolder1 } = $subfolder1 ; + if ( ! add_subfolder1_to_folderrec( $mysync ) ) + { + $mysync->{nb_errors}++ ; + exit_clean( $mysync, $EXIT_SUBFOLDER1_NO_EXISTS, "subfolder1 $subfolder1 does not exist\n" ) ; + } + } + else + { + $mysync->{ subfolder1 } = undef ; + } + + return ; +} + +sub subfolder2 +{ + my $mysync = shift @ARG ; + my $subfolder2 = sanitize_subfolder( $mysync->{ subfolder2 } ) ; + if ( $subfolder2 ) + { + # turns off automap + myprint( "Turning off automapping folders because of --subfolder2\n" ) ; + $mysync->{ automap } = undef ; + myprint( "Sanitizing subfolder2: [$mysync->{ subfolder2 }] => [$subfolder2]\n" ) ; + $mysync->{ subfolder2 } = $subfolder2 ; + set_regextrans2_for_subfolder2( $mysync ) ; + } + else + { + $mysync->{ subfolder2 } = undef ; + } + + return ; +} + +sub tests_sanitize_subfolder +{ + note( 'Entering tests_sanitize_subfolder()' ) ; + + is( undef, sanitize_subfolder( ), 'sanitize_subfolder: no args => undef' ) ; + is( undef, sanitize_subfolder( q{} ), 'sanitize_subfolder: empty => undef' ) ; + is( undef, sanitize_subfolder( ' ' ), 'sanitize_subfolder: blank => undef' ) ; + is( undef, sanitize_subfolder( ' ' ), 'sanitize_subfolder: blanks => undef' ) ; + is( 'abcd', sanitize_subfolder( 'abcd' ), 'sanitize_subfolder: abcd => abcd' ) ; + is( 'ab cd', sanitize_subfolder( ' ab cd ' ), 'sanitize_subfolder: " ab cd " => "ab cd"' ) ; + is( 'abcd', sanitize_subfolder( q{a&~b#\\c[]=d;} ), 'sanitize_subfolder: "a&~b#\\c[]=d;" => "abcd"' ) ; + is( 'aA.b-_ 8c/dD', sanitize_subfolder( 'aA.b-_ 8c/dD' ), 'sanitize_subfolder: aA.b-_ 8c/dD => aA.b-_ 8c/dD' ) ; + note( 'Leaving tests_sanitize_subfolder()' ) ; + return ; +} + + +sub sanitize_subfolder +{ + my $subfolder = shift @ARG ; + + if ( ! $subfolder ) + { + return ; + } + # Remove edging blanks + $subfolder =~ s,^ +| +$,,g ; + # Keep only abcd...ABCD...0123... and -_./ + $subfolder =~ tr,-_a-zA-Z0-9./ ,,cd ; + + # A blank subfolder is not a subfolder + if ( ! $subfolder ) + { + return ; + } + else + { + return $subfolder ; + } +} + +sub tests_sanitize_host +{ + note( 'Entering tests_sanitize_host()' ) ; + + is( undef, sanitize_host( ), 'sanitize_host: no args => undef' ) ; + is( '', sanitize_host( '' ), 'sanitize_host: empty => empty' ) ; + is( 'imap.example.org', sanitize_host( 'imap.example.org' ), 'sanitize_host: imap.example.org => imap.example.org' ) ; + is( 'imap.example.org', sanitize_host( ' imap.example.org' ), 'sanitize_host: imap.example.org 1 => imap.example.org' ) ; + is( 'imap.example.org', sanitize_host( 'imap.example.org ' ), 'sanitize_host: imap.example.org 2 => imap.example.org' ) ; + is( 'imap.example.org', sanitize_host( 'imap.exam ple.org' ), 'sanitize_host: imap.example.org 3 => imap.example.org' ) ; + is( 'imap.example.org', sanitize_host( ' imap.exam ple.org ' ), 'sanitize_host: imap.example.org 4 => imap.example.org' ) ; + is( 'imap.example.org', sanitize_host( 'imap.exa/mple.org/' ), 'sanitize_host: imap.example.org/ => imap.example.org' ) ; + + note( 'Leaving tests_sanitize_host()' ) ; + return ; +} + + +sub sanitize_host +{ + my $host = shift @ARG ; + if ( ! defined $host ) { return ; } + + $host =~ tr{ /}{}d ; + return $host ; +} + + +sub tests_add_subfolder1_to_folderrec +{ + note( 'Entering tests_add_subfolder1_to_folderrec()' ) ; + + is( undef, add_subfolder1_to_folderrec( ), 'add_subfolder1_to_folderrec: undef => undef' ) ; + is_deeply( [], [ add_subfolder1_to_folderrec( ) ], 'add_subfolder1_to_folderrec: no args => empty array' ) ; + @folderrec = () ; + my $mysync = {} ; + is_deeply( [ ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: empty => empty array' ) ; + is_deeply( [ ], [ @folderrec ], 'add_subfolder1_to_folderrec: empty => empty folderrec' ) ; + $mysync->{ subfolder1 } = 'SUBI' ; + $h1_folders_all{ 'SUBI' } = 1 ; + $mysync->{ h1_prefix } = 'INBOX/' ; + is_deeply( [ 'SUBI' ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBI => SUBI' ) ; + is_deeply( [ 'SUBI' ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBI => folderrec SUBI ' ) ; + + @folderrec = () ; + $mysync->{ subfolder1 } = 'SUBO' ; + is_deeply( [ ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBO no exists => empty array' ) ; + is_deeply( [ ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBO no exists => empty folderrec' ) ; + $h1_folders_all{ 'INBOX/SUBO' } = 1 ; + is_deeply( [ 'INBOX/SUBO' ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBO + INBOX/SUBO exists => INBOX/SUBO' ) ; + is_deeply( [ 'INBOX/SUBO' ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBO + INBOX/SUBO exists => INBOX/SUBO folderrec' ) ; + + note( 'Leaving tests_add_subfolder1_to_folderrec()' ) ; + return ; +} + + +sub add_subfolder1_to_folderrec +{ + my $mysync = shift @ARG ; + if ( ! $mysync || ! $mysync->{ subfolder1 } ) + { + return ; + } + + my $subfolder1 = $mysync->{ subfolder1 } ; + my $subfolder1_extended = $mysync->{ h1_prefix } . $subfolder1 ; + + if ( exists $h1_folders_all{ $subfolder1 } ) + { + myprint( qq{Acting like --folderrec "$subfolder1"\n} ) ; + push @folderrec, $subfolder1 ; + } + elsif ( exists $h1_folders_all{ $subfolder1_extended } ) + { + myprint( qq{Acting like --folderrec "$subfolder1_extended"\n} ) ; + push @folderrec, $subfolder1_extended ; + } + else + { + myprint( qq{Nor folder "$subfolder1" nor "$subfolder1_extended" exists on host1\n} ) ; + } + return @folderrec ; +} + +sub set_regextrans2_for_subfolder2 +{ + my $mysync = shift @ARG ; + + + unshift @{ $mysync->{ regextrans2 } }, + q(s,^$mysync->{ h2_prefix }(.*),$mysync->{ h2_prefix }$mysync->{ subfolder2 }$mysync->{ h2_sep }$1,), + q(s,^INBOX$,$mysync->{ h2_prefix }$mysync->{ subfolder2 }$mysync->{ h2_sep }INBOX,), + q(s,^($mysync->{ h2_prefix }){2},$mysync->{ h2_prefix },); + + #myprint( "@{ $mysync->{ regextrans2 } }\n" ) ; + return ; +} + + + +# Looks like no globals here + +sub tests_imap2_folder_name +{ + note( 'Entering tests_imap2_folder_name()' ) ; + + my $mysync = {} ; + $mysync->{ h1_prefix } = q{} ; + $mysync->{ h2_prefix } = q{} ; + $mysync->{ h1_sep } = '/'; + $mysync->{ h2_sep } = '.'; + + $mysync->{ debug } and myprint( <<"EOS" +prefix1: [$mysync->{ h1_prefix }] +prefix2: [$mysync->{ h2_prefix }] +sep1: [$sync->{ h1_sep }] +sep2: [$sync->{ h2_sep }] +EOS +) ; + + $mysync->{ fixslash2 } = 0 ; + is( q{INBOX}, imap2_folder_name( $mysync, q{} ), 'imap2_folder_name: empty string' ) ; + is( 'blabla', imap2_folder_name( $mysync, 'blabla' ), 'imap2_folder_name: blabla' ) ; + is('spam.spam', imap2_folder_name( $mysync, 'spam/spam' ), 'imap2_folder_name: spam/spam' ) ; + + is( 'spam/spam', imap2_folder_name( $mysync, 'spam.spam' ), 'imap2_folder_name: spam.spam') ; + is( 'spam.spam/spam', imap2_folder_name( $mysync, 'spam/spam.spam' ), 'imap2_folder_name: spam/spam.spam' ) ; + is( 's pam.spam/sp am', imap2_folder_name( $mysync, 's pam/spam.sp am' ), 'imap2_folder_name: s pam/spam.sp am' ) ; + + $mysync->{f1f2h}{ 'auto' } = 'moto' ; + is( 'moto', imap2_folder_name( $mysync, 'auto' ), 'imap2_folder_name: auto' ) ; + $mysync->{f1f2h}{ 'auto/auto' } = 'moto x 2' ; + is( 'moto x 2', imap2_folder_name( $mysync, 'auto/auto' ), 'imap2_folder_name: auto/auto' ) ; + + @{ $mysync->{ regextrans2 } } = ( 's,/,X,g' ) ; + is( q{INBOX}, imap2_folder_name( $mysync, q{} ), 'imap2_folder_name: empty string [s,/,X,g]' ) ; + is( 'blabla', imap2_folder_name( $mysync, 'blabla' ), 'imap2_folder_name: blabla [s,/,X,g]' ) ; + is('spam.spam', imap2_folder_name( $mysync, 'spam/spam'), 'imap2_folder_name: spam/spam [s,/,X,g]'); + is('spamXspam', imap2_folder_name( $mysync, 'spam.spam'), 'imap2_folder_name: spam.spam [s,/,X,g]'); + is('spam.spamXspam', imap2_folder_name( $mysync, 'spam/spam.spam'), 'imap2_folder_name: spam/spam.spam [s,/,X,g]'); + + @{ $mysync->{ regextrans2 } } = ( 's, ,_,g' ) ; + is('blabla', imap2_folder_name( $mysync, 'blabla'), 'imap2_folder_name: blabla [s, ,_,g]'); + is('bla_bla', imap2_folder_name( $mysync, 'bla bla'), 'imap2_folder_name: blabla [s, ,_,g]'); + + @{ $mysync->{ regextrans2 } } = ( q{s,(.*),\U$1,} ) ; + is( 'BLABLA', imap2_folder_name( $mysync, 'blabla' ), q{imap2_folder_name: blabla [s,\U(.*)\E,$1,]} ) ; + + $mysync->{ fixslash2 } = 1 ; + @{ $mysync->{ regextrans2 } } = ( ) ; + is(q{INBOX}, imap2_folder_name( $mysync, q{}), 'imap2_folder_name: empty string'); + is('blabla', imap2_folder_name( $mysync, 'blabla'), 'imap2_folder_name: blabla'); + is('spam.spam', imap2_folder_name( $mysync, 'spam/spam'), 'imap2_folder_name: spam/spam -> spam.spam'); + is('spam_spam', imap2_folder_name( $mysync, 'spam.spam'), 'imap2_folder_name: spam.spam -> spam_spam'); + is('spam.spam_spam', imap2_folder_name( $mysync, 'spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam_spam'); + is('s pam.spam_spa m', imap2_folder_name( $mysync, 's pam/spam.spa m'), 'imap2_folder_name: s pam/spam.spa m -> s pam.spam_spa m'); + + $mysync->{ h1_sep } = '.'; + $mysync->{ h2_sep } = '/'; + is( q{INBOX}, imap2_folder_name( $mysync, q{}), 'imap2_folder_name: empty string'); + is('blabla', imap2_folder_name( $mysync, 'blabla'), 'imap2_folder_name: blabla'); + is('spam.spam', imap2_folder_name( $mysync, 'spam/spam'), 'imap2_folder_name: spam/spam -> spam.spam'); + is('spam/spam', imap2_folder_name( $mysync, 'spam.spam'), 'imap2_folder_name: spam.spam -> spam/spam'); + is('spam.spam/spam', imap2_folder_name( $mysync, 'spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam'); + + + + $mysync->{ fixslash2 } = 0 ; + $mysync->{ h1_prefix } = q{ }; + + is( 'spam.spam/spam', imap2_folder_name( $mysync, 'spam/spam.spam' ), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam' ) ; + is( 'spam.spam/spam', imap2_folder_name( $mysync, ' spam/spam.spam' ), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam' ) ; + + $mysync->{ h1_sep } = '.' ; + $mysync->{ h2_sep } = '/' ; + $mysync->{ h1_prefix } = 'INBOX.' ; + $mysync->{ h2_prefix } = q{} ; + @{ $mysync->{ regextrans2 } } = ( q{s,(.*),\U$1,} ) ; + is( 'BLABLA', imap2_folder_name( $mysync, 'blabla' ), 'imap2_folder_name: blabla' ) ; + is( 'TEST/TEST/TEST/TEST', imap2_folder_name( $mysync, 'INBOX.TEST.test.Test.tesT' ), 'imap2_folder_name: INBOX.TEST.test.Test.tesT' ) ; + @{ $mysync->{ regextrans2 } } = ( q{s,(.*),\L$1,} ) ; + is( 'test/test/test/test', imap2_folder_name( $mysync, 'INBOX.TEST.test.Test.tesT' ), 'imap2_folder_name: INBOX.TEST.test.Test.tesT' ) ; + + # INBOX + $mysync = {} ; + $mysync->{ h1_prefix } = q{Pf1.} ; + $mysync->{ h2_prefix } = q{Pf2/} ; + $mysync->{ h1_sep } = '.'; + $mysync->{ h2_sep } = '/'; + + # + #$mysync->{ debug } = 1 ; + is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'F1.F2.F3' ), 'imap2_folder_name: F1.F2.F3 -> Pf2/F1/F2/F3' ) ; + is( 'Pf2/F1/INBOX', imap2_folder_name( $mysync, 'F1.INBOX' ), 'imap2_folder_name: F1.INBOX -> Pf2/F1/INBOX' ) ; + is( 'INBOX', imap2_folder_name( $mysync, 'INBOX' ), 'imap2_folder_name: INBOX -> INBOX' ) ; + + is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'Pf1.F1.F2.F3' ), 'imap2_folder_name: Pf1.F1.F2.F3 -> Pf2/F1/F2/F3' ) ; + is( 'Pf2/F1/INBOX', imap2_folder_name( $mysync, 'Pf1.F1.INBOX' ), 'imap2_folder_name: Pf1.F1.INBOX -> Pf2/F1/INBOX' ) ; + is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.INBOX' ), 'imap2_folder_name: Pf1.INBOX -> INBOX' ) ; # not Pf2/INBOX: Yes I can! + + + + # subfolder2 + $mysync = {} ; + $mysync->{ h1_prefix } = q{} ; + $mysync->{ h2_prefix } = q{} ; + $mysync->{ h1_sep } = '/'; + $mysync->{ h2_sep } = '.'; + + + set_regextrans2_for_subfolder2( $mysync ) ; + $mysync->{ subfolder2 } = 'S1.S2' ; + is( 'S1.S2.F1.F2.F3', imap2_folder_name( $mysync, 'F1/F2/F3' ), 'imap2_folder_name: F1/F2/F3 -> S1.S2.F1.F2.F3' ) ; + is( 'S1.S2.INBOX', imap2_folder_name( $mysync, 'INBOX' ), 'imap2_folder_name: F1/F2/F3 -> S1.S2.INBOX' ) ; + + $mysync = {} ; + $mysync->{ h1_prefix } = q{Pf1/} ; + $mysync->{ h2_prefix } = q{Pf2.} ; + $mysync->{ h1_sep } = '/'; + $mysync->{ h2_sep } = '.'; + #$mysync->{ debug } = 1 ; + + set_regextrans2_for_subfolder2( $mysync ) ; + $mysync->{ subfolder2 } = 'Pf2.S1.S2' ; + is( 'Pf2.S1.S2.F1.F2.F3', imap2_folder_name( $mysync, 'F1/F2/F3' ), 'imap2_folder_name: F1/F2/F3 -> Pf2.S1.S2.F1.F2.F3' ) ; + is( 'Pf2.S1.S2.INBOX', imap2_folder_name( $mysync, 'INBOX' ), 'imap2_folder_name: INBOX -> Pf2.S1.S2.INBOX' ) ; + is( 'Pf2.S1.S2.F1.F2.F3', imap2_folder_name( $mysync, 'Pf1/F1/F2/F3' ), 'imap2_folder_name: F1/F2/F3 -> Pf2.S1.S2.F1.F2.F3' ) ; + is( 'Pf2.S1.S2.INBOX', imap2_folder_name( $mysync, 'Pf1/INBOX' ), 'imap2_folder_name: INBOX -> Pf2.S1.S2.INBOX' ) ; + + # subfolder1 + # scenario as the reverse of the previous tests, separators point of vue + $mysync = {} ; + $mysync->{ h1_prefix } = q{Pf1.} ; + $mysync->{ h2_prefix } = q{Pf2/} ; + $mysync->{ h1_sep } = '.'; + $mysync->{ h2_sep } = '/'; + #$mysync->{ debug } = 1 ; + + $mysync->{ subfolder1 } = 'S1.S2' ; + is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'S1.S2.F1.F2.F3' ), 'imap2_folder_name: S1.S2.F1.F2.F3 -> Pf2/F1/F2/F3' ) ; + is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'Pf1.S1.S2.F1.F2.F3' ), 'imap2_folder_name: Pf1.S1.S2.F1.F2.F3 -> Pf2/F1/F2/F3' ) ; + + is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.INBOX' ), 'imap2_folder_name: S1.S2.INBOX -> INBOX' ) ; + is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2' ), 'imap2_folder_name: S1.S2 -> INBOX' ) ; + is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.' ), 'imap2_folder_name: S1.S2. -> INBOX' ) ; + + is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.INBOX' ), 'imap2_folder_name: Pf1.S1.S2.INBOX -> INBOX' ) ; + is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2' ), 'imap2_folder_name: Pf1.S1.S2 -> INBOX' ) ; + is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.' ), 'imap2_folder_name: Pf1.S1.S2. -> INBOX' ) ; + + + $mysync->{ subfolder1 } = 'S1.S2.' ; + is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'S1.S2.F1.F2.F3' ), 'imap2_folder_name: S1.S2.F1.F2.F3 -> Pf2/F1/F2/F3' ) ; + is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'Pf1.S1.S2.F1.F2.F3' ), 'imap2_folder_name: Pf1.S1.S2.F1.F2.F3 -> Pf2/F1/F2/F3' ) ; + + is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.INBOX' ), 'imap2_folder_name: S1.S2.INBOX -> INBOX' ) ; + is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2' ), 'imap2_folder_name: S1.S2 -> INBOX' ) ; + is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.' ), 'imap2_folder_name: S1.S2. -> INBOX' ) ; + + is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.INBOX' ), 'imap2_folder_name: Pf1.S1.S2.INBOX -> INBOX' ) ; + is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2' ), 'imap2_folder_name: Pf1.S1.S2 -> INBOX' ) ; + is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.' ), 'imap2_folder_name: Pf1.S1.S2. -> INBOX' ) ; + + + # subfolder1 + # scenario as Gmail + $mysync = {} ; + $mysync->{ h1_prefix } = q{} ; + $mysync->{ h2_prefix } = q{} ; + $mysync->{ h1_sep } = '/'; + $mysync->{ h2_sep } = '/'; + #$mysync->{ debug } = 1 ; + + $mysync->{ subfolder1 } = 'S1/S2' ; + is( 'F1/F2/F3', imap2_folder_name( $mysync, 'S1/S2/F1/F2/F3' ), 'imap2_folder_name: S1/S2/F1/F2/F3 -> F1/F2/F3' ) ; + is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/INBOX' ), 'imap2_folder_name: S1/S2/INBOX -> INBOX' ) ; + is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2' ), 'imap2_folder_name: S1/S2 -> INBOX' ) ; + is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/' ), 'imap2_folder_name: S1/S2/ -> INBOX' ) ; + + $mysync->{ subfolder1 } = 'S1/S2/' ; + is( 'F1/F2/F3', imap2_folder_name( $mysync, 'S1/S2/F1/F2/F3' ), 'imap2_folder_name: S1/S2/F1/F2/F3 -> F1/F2/F3' ) ; + is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/INBOX' ), 'imap2_folder_name: S1/S2/INBOX -> INBOX' ) ; + is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2' ), 'imap2_folder_name: S1/S2 -> INBOX' ) ; + is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/' ), 'imap2_folder_name: S1/S2/ -> INBOX' ) ; + + + note( 'Leaving tests_imap2_folder_name()' ) ; + return ; +} + + +# Global variables to remove: +# None? + + +sub imap2_folder_name +{ + my $mysync = shift @ARG ; + my ( $h1_fold ) = shift @ARG ; + my ( $h2_fold ) ; + if ( $mysync->{f1f2h}{ $h1_fold } ) { + $h2_fold = $mysync->{f1f2h}{ $h1_fold } ; + ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "f1f2 [$h1_fold] -> [$h2_fold]\n" ) ; + return( $h2_fold ) ; + } + if ( $mysync->{f1f2auto}{ $h1_fold } ) { + $h2_fold = $mysync->{f1f2auto}{ $h1_fold } ; + ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "automap [$h1_fold] -> [$h2_fold]\n" ) ; + return( $h2_fold ) ; + } + + if ( $mysync->{ subfolder1 } ) + { + my $esc_h1_sep = "\\" . $mysync->{ h1_sep } ; + # case where subfolder1 has the sep1 at the end, then remove it + my $part_to_removed = remove_last_char_if_is( $mysync->{ subfolder1 }, $mysync->{ h1_sep } ) ; + # remove the subfolder1 part and the sep1 if present after + $h1_fold =~ s{$part_to_removed($esc_h1_sep)?}{} ; + #myprint( "h1_fold=$h1_fold\n" ) ; + } + + if ( ( q{} eq $h1_fold ) or ( $mysync->{ h1_prefix } eq $h1_fold ) ) + { + $h1_fold = 'INBOX' ; + } + + $h2_fold = prefix_seperator_invertion( $mysync, $h1_fold ) ; + $h2_fold = regextrans2( $mysync, $h2_fold ) ; + return( $h2_fold ) ; +} + + +sub tests_remove_last_char_if_is +{ + note( 'Entering tests_remove_last_char_if_is()' ) ; + + is( undef, remove_last_char_if_is( ), 'remove_last_char_if_is: no args => undef' ) ; + is( q{}, remove_last_char_if_is( q{} ), 'remove_last_char_if_is: empty => empty' ) ; + is( q{}, remove_last_char_if_is( q{}, 'Z' ), 'remove_last_char_if_is: empty Z => empty' ) ; + is( q{}, remove_last_char_if_is( 'Z', 'Z' ), 'remove_last_char_if_is: Z Z => empty' ) ; + is( 'abc', remove_last_char_if_is( 'abcZ', 'Z' ), 'remove_last_char_if_is: abcZ Z => abc' ) ; + is( 'abcY', remove_last_char_if_is( 'abcY', 'Z' ), 'remove_last_char_if_is: abcY Z => abcY' ) ; + note( 'Leaving tests_remove_last_char_if_is()' ) ; + return ; +} + + + + +sub remove_last_char_if_is +{ + my $string = shift @ARG ; + my $char = shift @ARG ; + + if ( ! defined $string ) + { + return ; + } + + if ( ! defined $char ) + { + return $string ; + } + + my $last_char = substr $string, -1 ; + if ( $char eq $last_char ) + { + chop $string ; + return $string ; + } + else + { + return $string ; + } +} + +sub tests_prefix_seperator_invertion +{ + note( 'Entering tests_prefix_seperator_invertion()' ) ; + + is( undef, prefix_seperator_invertion( ), 'prefix_seperator_invertion: no args => undef' ) ; + is( q{}, prefix_seperator_invertion( undef, q{} ), 'prefix_seperator_invertion: empty string => empty string' ) ; + is( 'lalala', prefix_seperator_invertion( undef, 'lalala' ), 'prefix_seperator_invertion: lalala => lalala' ) ; + is( 'lal/ala', prefix_seperator_invertion( undef, 'lal/ala' ), 'prefix_seperator_invertion: lal/ala => lal/ala' ) ; + is( 'lal.ala', prefix_seperator_invertion( undef, 'lal.ala' ), 'prefix_seperator_invertion: lal.ala => lal.ala' ) ; + is( '////', prefix_seperator_invertion( undef, '////' ), 'prefix_seperator_invertion: //// => ////' ) ; + is( '.....', prefix_seperator_invertion( undef, '.....' ), 'prefix_seperator_invertion: ..... => .....' ) ; + + my $mysync = { + h1_prefix => q{}, + h2_prefix => q{}, + h1_sep => '/', + h2_sep => '/', + } ; + + is( q{}, prefix_seperator_invertion( $mysync, q{} ), 'prefix_seperator_invertion: $mysync empty string => empty string' ) ; + is( 'lalala', prefix_seperator_invertion( $mysync, 'lalala' ), 'prefix_seperator_invertion: $mysync lalala => lalala' ) ; + is( 'lal/ala', prefix_seperator_invertion( $mysync, 'lal/ala' ), 'prefix_seperator_invertion: $mysync lal/ala => lal/ala' ) ; + is( 'lal.ala', prefix_seperator_invertion( $mysync, 'lal.ala' ), 'prefix_seperator_invertion: $mysync lal.ala => lal.ala' ) ; + is( '////', prefix_seperator_invertion( $mysync, '////' ), 'prefix_seperator_invertion: $mysync //// => ////' ) ; + is( '.....', prefix_seperator_invertion( $mysync, '.....' ), 'prefix_seperator_invertion: $mysync ..... => .....' ) ; + + $mysync = { + h1_prefix => 'PPP', + h2_prefix => 'QQQ', + h1_sep => 's', + h2_sep => 't', + } ; + + is( q{QQQ}, prefix_seperator_invertion( $mysync, q{} ), 'prefix_seperator_invertion: PPPQQQst empty string => QQQ' ) ; + is( 'QQQlalala', prefix_seperator_invertion( $mysync, 'lalala' ), 'prefix_seperator_invertion: PPPQQQst lalala => QQQlalala' ) ; + is( 'QQQlal/ala', prefix_seperator_invertion( $mysync, 'lal/ala' ), 'prefix_seperator_invertion: PPPQQQst lal/ala => QQQlal/ala' ) ; + is( 'QQQlal.ala', prefix_seperator_invertion( $mysync, 'lal.ala' ), 'prefix_seperator_invertion: PPPQQQst lal.ala => QQQlal.ala' ) ; + is( 'QQQ////', prefix_seperator_invertion( $mysync, '////' ), 'prefix_seperator_invertion: PPPQQQst //// => QQQ////' ) ; + is( 'QQQ.....', prefix_seperator_invertion( $mysync, '.....' ), 'prefix_seperator_invertion: PPPQQQst ..... => QQQ.....' ) ; + + is( 'QQQPlalala', prefix_seperator_invertion( $mysync, 'PPPPlalala' ), 'prefix_seperator_invertion: PPPQQQst PPPPlalala => QQQPlalala' ) ; + is( 'QQQ', prefix_seperator_invertion( $mysync, 'PPP' ), 'prefix_seperator_invertion: PPPQQQst PPP => QQQ' ) ; + is( 'QQQttt', prefix_seperator_invertion( $mysync, 'sss' ), 'prefix_seperator_invertion: PPPQQQst sss => QQQttt' ) ; + is( 'QQQt', prefix_seperator_invertion( $mysync, 's' ), 'prefix_seperator_invertion: PPPQQQst s => QQQt' ) ; + is( 'QQQtAAAtBBB', prefix_seperator_invertion( $mysync, 'PPPsAAAsBBB' ), 'prefix_seperator_invertion: PPPQQQst PPPsAAAsBBB => QQQtAAAtBBB' ) ; + + note( 'Leaving tests_prefix_seperator_invertion()' ) ; + return ; +} + +# Global variables to remove: + + +sub prefix_seperator_invertion +{ + my $mysync = shift @ARG ; + my $h1_fold = shift @ARG ; + my $h2_fold ; + + if ( not defined $h1_fold ) { return ; } + + my $my_h1_prefix = $mysync->{ h1_prefix } || q{} ; + my $my_h2_prefix = $mysync->{ h2_prefix } || q{} ; + my $my_h1_sep = $mysync->{ h1_sep } || '/' ; + my $my_h2_sep = $mysync->{ h2_sep } || '/' ; + + # first we remove the prefix + $h1_fold =~ s/^\Q$my_h1_prefix\E//x ; + ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "removed host1 prefix: [$h1_fold]\n" ) ; + $h2_fold = separator_invert( $mysync, $h1_fold, $my_h1_sep, $my_h2_sep ) ; + ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "inverted separators: [$h2_fold]\n" ) ; + + # Adding the prefix supplied by namespace or the --prefix2 option + # except for INBOX or Inbox + if ( $h2_fold !~ m/^INBOX$/xi ) + { + $h2_fold = $my_h2_prefix . $h2_fold ; + } + + ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "added host2 prefix: [$h2_fold]\n" ) ; + return( $h2_fold ) ; +} + +sub tests_separator_invert +{ + note( 'Entering tests_separator_invert()' ) ; + + my $mysync = {} ; + $mysync->{ fixslash2 } = 0 ; + ok( not( defined separator_invert( ) ), 'separator_invert: no args' ) ; + ok( not( defined separator_invert( q{} ) ), 'separator_invert: not enough args' ) ; + ok( not( defined separator_invert( q{}, q{} ) ), 'separator_invert: not enough args' ) ; + + ok( q{} eq separator_invert( $mysync, q{}, q{}, q{} ), 'separator_invert: 3 empty strings' ) ; + ok( 'lalala' eq separator_invert( $mysync, 'lalala', q{}, q{} ), 'separator_invert: empty separator' ) ; + ok( 'lalala' eq separator_invert( $mysync, 'lalala', '/', '/' ), 'separator_invert: same separator /' ) ; + ok( 'lal/ala' eq separator_invert( $mysync, 'lal/ala', '/', '/' ), 'separator_invert: same separator / 2' ) ; + ok( 'lal.ala' eq separator_invert( $mysync, 'lal/ala', '/', '.' ), 'separator_invert: separators /.' ) ; + ok( 'lal/ala' eq separator_invert( $mysync, 'lal.ala', '.', '/' ), 'separator_invert: separators ./' ) ; + ok( 'la.l/ala' eq separator_invert( $mysync, 'la/l.ala', '.', '/' ), 'separator_invert: separators ./' ) ; + + ok( 'l/al.ala' eq separator_invert( $mysync, 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ; + $mysync->{ fixslash2 } = 1 ; + ok( 'l_al.ala' eq separator_invert( $mysync, 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ; + + note( 'Leaving tests_separator_invert()' ) ; + return ; +} + +# Global variables to remove: +# +sub separator_invert +{ + my( $mysync, $h1_fold, $h1_separator, $h2_separator ) = @_ ; + + return( undef ) if ( not all_defined( $mysync, $h1_fold, $h1_separator, $h2_separator ) ) ; + # The separator we hope we'll never encounter: 00000000 == 0x00 + my $o_sep = "\000" ; + + my $h2_fold = $h1_fold ; + $h2_fold =~ s,\Q$h2_separator,$o_sep,xg ; + $h2_fold =~ s,\Q$h1_separator,$h2_separator,xg ; + $h2_fold =~ s,\Q$o_sep,$h1_separator,xg ; + $h2_fold =~ s,/,_,xg if( $mysync->{ fixslash2 } and '/' ne $h2_separator and '/' eq $h1_separator ) ; + return( $h2_fold ) ; +} + + +sub regextrans2 +{ + my( $mysync, $h2_fold ) = @_ ; + # Transforming the folder name by the --regextrans2 option(s) + foreach my $regextrans2 ( @{ $mysync->{ regextrans2 } } ) { + my $h2_fold_before = $h2_fold ; + my $ret = eval "\$h2_fold =~ $regextrans2 ; 1 " ; + ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "[$h2_fold_before] -> [$h2_fold] using regextrans2 [$regextrans2]\n" ) ; + if ( not ( defined $ret ) or $EVAL_ERROR ) { + $mysync->{nb_errors}++ ; + exit_clean( $mysync, $EX_USAGE, + "error: eval regextrans2 '$regextrans2': $EVAL_ERROR\n" + ) ; + } + } + return( $h2_fold ) ; +} + + +sub tests_decompose_regex +{ + note( 'Entering tests_decompose_regex()' ) ; + + ok( 1, 'decompose_regex 1' ) ; + ok( 0 == compare_lists( [ q{}, q{} ], [ decompose_regex( q{} ) ] ), 'decompose_regex empty string' ) ; + ok( 0 == compare_lists( [ '.*', 'lala' ], [ decompose_regex( 's/.*/lala/' ) ] ), 'decompose_regex s/.*/lala/' ) ; + + note( 'Leaving tests_decompose_regex()' ) ; + return ; +} + +sub decompose_regex +{ + my $regex = shift @ARG ; + my( $left_part, $right_part ) ; + + ( $left_part, $right_part ) = $regex =~ m{^s/((?:[^/]|\\/)+)/((?:[^/]|\\/)+)/}x; + return( q{}, q{} ) if not $left_part ; + return( $left_part, $right_part ) ; +} + + + +sub tests_timenext +{ + note( 'Entering tests_timenext()' ) ; + + is( undef, timenext( ), 'timenext: no args => undef' ) ; + my $mysync ; + is( undef, timenext( $mysync ), 'timenext: undef => undef' ) ; + $mysync = {} ; + ok( time - timenext( $mysync ) <= 1e-02, 'timenext: defined first time => ~ time' ) ; + ok( timenext( $mysync ) <= 1e-02, 'timenext: second time => less than 1e-02' ) ; + ok( timenext( $mysync ) <= 1e-02, 'timenext: third time => less than 1e-02' ) ; + + note( 'Leaving tests_timenext()' ) ; + return ; +} + + +sub timenext +{ + my $mysync = shift @ARG ; + + if ( ! defined $mysync ) + { + return ; + } + my ( $timenow, $timediff ) ; + + $mysync->{ timebefore } ||= 0; # epoch... + $timenow = time ; + $timediff = $timenow - $mysync->{ timebefore } ; + $mysync->{ timebefore } = $timenow ; + # myprint( "timenext: $timediff\n" ) ; + return( $timediff ) ; +} + + +sub tests_timesince +{ + note( 'Entering tests_timesince()' ) ; + + ok( timesince( time - 1 ) - 1 <= 1e-02, 'timesince: time - 1 => <= 1 + 1e-02' ) ; + ok( timesince( time ) <= 1e-02, 'timesince: time => <= 1e-02' ) ; + ok( timesince( ) - time <= 1e-02, 'timesince: no args => <= time + 1e-02' ) ; + note( 'Leaving tests_timesince()' ) ; + return ; +} + + + +sub timesince +{ + my $timeinit = shift || 0 ; + my ( $timenow, $timediff ) ; + $timenow = time ; + $timediff = $timenow - $timeinit ; + # Often used in a division so no 0 but a nano second. + return( max( $timediff, min( 1e-09, $timediff ) ) ) ; +} + + + + +sub tests_regexflags +{ + note( 'Entering tests_regexflags()' ) ; + + my $mysync = {} ; + + ok( q{} eq regexflags( $mysync, q{} ), 'regexflags, null string q{}' ) ; + ok( q{\Seen NonJunk $Spam} eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{regexflags, nothing to do} ) ; + + @{ $mysync->{ regexflag } } = ('I am BAD' ) ; + ok( not ( defined regexflags( $mysync, q{} ) ), 'regexflags, bad regex' ) ; + + @{ $mysync->{ regexflag } } = ( 's/NonJunk//g' ) ; + ok( q{\Seen $Spam} eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{regexflags, remove NonJunk: 's/NonJunk//g'} ) ; + @{ $mysync->{ regexflag } } = ( q{s/\$Spam//g} ) ; + ok( q{\Seen NonJunk } eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{regexflags, remove $Spam: 's/\$Spam//g'} ) ; + + @{ $mysync->{ regexflag } } = ( 's/\\\\Seen//g' ) ; + + ok( q{ NonJunk $Spam} eq regexflags( $mysync, q{\Seen NonJunk $Spam} ), q{regexflags, remove \Seen: 's/\\\\\\\\Seen//g'} ) ; + + @{ $mysync->{ regexflag } } = ( 's/(\s|^)[^\\\\]\w+//g' ) ; + ok( q{\Seen \Middle \End} eq regexflags( $mysync, q{\Seen NonJunk \Middle $Spam \End} ), q{regexflags: only \word among \Seen NonJunk \Middle $Spam \End} ) ; + ok( q{ \Seen \Middle \End1} eq regexflags( $mysync, q{Begin \Seen NonJunk \Middle $Spam \End1 End} ), + q{regexflags: only \word among Begin \Seen NonJunk \Middle $Spam \End1 End} ) ; + + @{ $mysync->{ regexflag } } = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g} ) ; + ok( 'Keep1 Keep2 ReB' eq regexflags( $mysync, 'ReA Keep1 REM Keep2 ReB' ), 'Keep only regex' ) ; + + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM REM Keep1 Keep2' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 REM REM Keep2' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM Keep1 REM REM Keep2' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 Keep2' ), 'Keep only regex' ) ; + ok( 'Keep1 ' eq regexflags( $mysync, 'REM Keep1' ), 'Keep only regex' ) ; + + @{ $mysync->{ regexflag } } = ( q{s/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g} ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 Keep2 ReB' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 Keep2 REM REM REM' ), 'Keep only regex' ) ; + ok( 'Keep2 ' eq regexflags( $mysync, 'Keep2 REM REM REM' ), 'Keep only regex' ) ; + + + @{ $mysync->{ regexflag } } = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g}, + 's/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM Keep1 REM Keep2 REM' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'Keep1 REM Keep2 REM' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM Keep1 Keep2 REM' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 ' eq regexflags( $mysync, 'REM Keep1 REM Keep2' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep2 Keep3 ' eq regexflags( $mysync, 'REM Keep1 REM Keep2 REM REM Keep3 REM' ), 'Keep only regex' ) ; + ok( 'Keep1 ' eq regexflags( $mysync, 'REM REM Keep1 REM REM REM ' ), 'Keep only regex' ) ; + ok( 'Keep1 Keep3 ' eq regexflags( $mysync, 'RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 ' ), 'Keep only regex' ) ; + + @{ $mysync->{ regexflag } } = ( 's/(.*)/$1 jrdH8u/' ) ; + ok('REM REM REM REM REM jrdH8u' eq regexflags( $mysync, 'REM REM REM REM REM' ), q{Add jrdH8u 's/(.*)/\$1 jrdH8u/'} ) ; + @{ $mysync->{ regexflag } } = ('s/jrdH8u *//' ); + ok('REM REM REM REM REM ' eq regexflags( $mysync, 'REM REM REM REM REM jrdH8u' ), q{Remove jrdH8u s/jrdH8u *//} ) ; + + @{ $mysync->{ regexflag } } = ( + 's/.*?(?:(\\\\(?:Answered|Flagged|Deleted|Seen|Draft)\s?)|$)/defined($1)?$1:q()/eg' + ); + + ok( '\\Deleted \\Answered ' + eq regexflags( $mysync, 'Blabla \$Junk \\Deleted machin \\Answered truc' ), + 'Keep only regex: Exchange case (Phil)' ) ; + + ok( q{} eq regexflags( $mysync, q{} ), 'Keep only regex: Exchange case, null string (Phil)' ) ; + + ok( q{} + eq regexflags( $mysync, 'Blabla $Junk machin truc' ), + 'Keep only regex: Exchange case, no accepted flags (Phil)' ) ; + + ok('\\Deleted \\Answered \\Draft \\Flagged ' + eq regexflags( $mysync, '\\Deleted \\Answered \\Draft \\Flagged ' ), + 'Keep only regex: Exchange case (Phil)' ) ; + + @{ $mysync->{ regexflag } } = ( 's/\\\\Flagged//g' ) ; + + is('\Deleted \Answered \Draft ', + regexflags( $mysync, '\\Deleted \\Answered \\Draft \\Flagged ' ), + 'regexflags: remove \Flagged 1' ) ; + + is('\\Deleted \\Answered \\Draft', + regexflags( $mysync, '\\Deleted \\Flagged \\Answered \\Draft' ), + 'regexflags: remove \Flagged 2' ) ; + + # I didn't understand why it gives \F + # https://perldoc.perl.org/perlrebackslash.html + # \F Foldcase till \E. Not in []. + # https://perldoc.perl.org/functions/fc.html + + # \F Not available in old Perl so I comment the test + + # @{ $mysync->{ regexflag } } = ( 's/\\Flagged/X/g' ) ; + #is('\Deleted FX \Answered \FX \Draft \FX', + #regexflags( '\Deleted Flagged \Answered \Flagged \Draft \Flagged' ), + # 'regexflags: remove \Flagged 3 mistery...' ) ; + + is( '\\ \ ', '\ \\ ', 'regexflags: \\ \ is \ \\ ' ) ; + note( 'Leaving tests_regexflags()' ) ; + return ; +} + +sub regexflags +{ + my $mysync = shift @ARG ; + my $flags = shift @ARG ; + + foreach my $regexflag ( @{ $mysync->{ regexflag } } ) + { + my $flags_orig = $flags ; + $mysync->{ debugflags } and myprint( "eval \$flags =~ $regexflag\n" ) ; + my $ret = eval "\$flags =~ $regexflag ; 1 " ; + $mysync->{ debugflags } and myprint( "regexflag $regexflag [$flags_orig] -> [$flags]\n" ) ; + if( not ( defined $ret ) or $EVAL_ERROR ) { + myprint( "Error: eval regexflag '$regexflag': $EVAL_ERROR\n" ) ; + return( undef ) ; + } + } + return( $flags ) ; +} + +sub tests_filterbuggyflags +{ + note( 'Entering tests_regexflags()' ) ; + + my $mysync = {} ; + + + $mysync->{ regexflag } = [ ] ; + $mysync->{ filterbuggyflags } = 1 ; + filterbuggyflags( $mysync ) ; + + # + is( '\Deleted \Answered \Draft \Flagged ', + regexflags( $mysync, '\\Deleted \\Answered \\RECEIPTCHECKED \\Draft \\Indexed \\Flagged \\JUNK \\Junk' ), + 'regexflags: remove famous /X 1' ) ; + + is( '\\Deleted \\Flagged \\Answered \\Draft', + regexflags( $mysync, '\\Deleted \\RECEIPTCHECKED \\Flagged \\Answered \\Indexed \\Draft' ), + 'regexflags: remove famous /X 2' ) ; + + is( '\ ', '\\ ', 'regexflags: \ is \\ ' ) ; + is( '\\ ', '\\ ', 'regexflags: \\ is \\ ' ) ; + + + note( 'Leaving tests_regexflags()' ) ; + return ; + + +} + +sub buggyflagsregex +{ + # From /X analyse + # cut -d: -f1 Error_112_all_syncs.txt | xargs egrep -oih 'Invalid system flag [^( ]+' | sort | uniq -c | sort -g + my @buggyflagsregex = ( 's/\\\\RECEIPTCHECKED|\\\\JUNK|\\\\Indexed|\\\\X-EON-HAS-ATTACHMENT|\\\\UNSEEN|\\\\ATTACHED|\\\\X-HAS-ATTACH|\\\\FORWARDED|\\\\FORWARD|\\\\X-FORWARDED|\\\\\$FORWARDED|\\\\PRIORITY|\\\\READRCPT//gi' ) ; + return( @buggyflagsregex ) ; +} + + +sub filterbuggyflags +{ + my $mysync = shift @ARG ; + if ( $mysync->{ filterbuggyflags } ) + { + unshift @{ $mysync->{ regexflag } }, buggyflagsregex( ) ; + } + return ; +} + + +sub tests_remove_doublequotes_if_any +{ + note( 'Entering tests_remove_doublequotes_if_any()' ) ; + # the number of tests is stupid here + is( undef, remove_doublequotes_if_any( ), 'remove_doublequotes_if_any: no args => undef' ) ; + is( q{}, remove_doublequotes_if_any( q{} ), 'remove_doublequotes_if_any: empty string => empty string' ) ; + is( q{}, remove_doublequotes_if_any( q{""} ), 'remove_doublequotes_if_any: double-quotes => empty string' ) ; + is( q{}, remove_doublequotes_if_any( q{"""} ), 'remove_doublequotes_if_any: double-quotes => empty string' ) ; + is( q{}, remove_doublequotes_if_any( q{"""} ), 'remove_doublequotes_if_any: double-quotes => empty string' ) ; + is( q{toto}, remove_doublequotes_if_any( q{"toto"} ), 'remove_doublequotes_if_any: "toto" => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{toto} ), 'remove_doublequotes_if_any: toto => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{to"to} ), 'remove_doublequotes_if_any: to"to => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{toto"} ), 'remove_doublequotes_if_any: toto" => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{"toto} ), 'remove_doublequotes_if_any: "toto => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{"to"to} ), 'remove_doublequotes_if_any: "to"to => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{to"to"} ), 'remove_doublequotes_if_any: to"to" => toto' ) ; + + is( q{toto}, remove_doublequotes_if_any( q{to\"to} ), 'remove_doublequotes_if_any: to\"to => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{toto\"} ), 'remove_doublequotes_if_any: toto\" => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{\"toto} ), 'remove_doublequotes_if_any: \"toto => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{\"to\"to} ), 'remove_doublequotes_if_any: \"to\"to => toto' ) ; + is( q{toto}, remove_doublequotes_if_any( q{to\"to\"} ), 'remove_doublequotes_if_any: to\"to" => toto' ) ; + + + note( 'Leaving tests_remove_doublequotes_if_any()' ) ; + return ; +} + + + +sub remove_doublequotes_if_any +{ + my $string = shift @ARG ; + + if ( ! defined $string ) { return ; } + $string =~ s/\\\"//g ; + $string =~ tr/"//d ; + return $string ; +} + + +# No globals here +sub acls_sync +{ +# https://tools.ietf.org/html/rfc4314 +# Standard Rights: +# https://tools.ietf.org/html/rfc4314#section-2.1 + + my( $mysync, $h1_fold, $h2_fold ) = @_ ; + if ( $mysync->{ syncacls } ) { + my $h1_hash = $mysync->{imap1}->getacl($h1_fold) + or myprint( "Host1: Could not getacl for $h1_fold: $EVAL_ERROR\n" ) ; + my $h2_hash = $mysync->{imap2}->getacl($h2_fold) + or myprint( "Host2: Could not getacl for $h2_fold: $EVAL_ERROR\n" ) ; + + my %users = map { ($_, 1) } ( keys %{ $h1_hash} , keys %{ $h2_hash } ) ; + foreach my $user (sort keys %users ) { + my $h1_acl = remove_doublequotes_if_any( $h1_hash->{$user} ) || '' ; + my $h2_acl = remove_doublequotes_if_any( $h2_hash->{$user} ) || '' ; + myprint( "Host1: user $user has acl [$h1_acl] on host1\n" ) ; + myprint( "Host2: user $user has acl [$h2_acl] on host2\n" ) ; + # removes surrounding double-quotes if any + my $user_no_quotes = remove_doublequotes_if_any( $user ) ; + + if ( $h1_hash->{$user} + && $h2_hash->{$user} + && $h1_hash->{$user} eq $h2_hash->{$user} ) + { + myprint( "Host2: user $user_no_quotes has already the same acl, no need to set it.\n" ) ; + next ; + } + myprint( "Host2: setting acl for folder $h2_fold user $user_no_quotes acl $h1_acl $mysync->{dry_message}\n" ) ; + unless ( $mysync->{dry} ) { + $mysync->{imap2}->setacl( $h2_fold, $user_no_quotes, $h1_acl ) + or myprint( "Could not set acl for user $user_no_quotes on host2: $EVAL_ERROR\n" ) ; + } + } + } + return ; +} + + +sub tests_permanentflags +{ + note( 'Entering tests_permanentflags()' ) ; + + my $mysync = { } ; + ok( q{} eq permanentflags( $mysync, ' * OK [PERMANENTFLAGS (\* \Draft \Answered)] Limited' ), + 'permanentflags \*' ) ; + + ok( '\Draft \Answered' eq permanentflags( $mysync, ' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited' ), + 'permanentflags \Draft \Answered' ) ; + + ok( '\Draft \Answered' + eq permanentflags( $mysync, 'Blabla', + ' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited', + 'Blabla' ), + 'permanentflags \Draft \Answered' + ) ; + + ok( q{} eq permanentflags( $mysync, 'Blabla' ), 'permanentflags nothing' ) ; + + note( 'Leaving tests_permanentflags()' ) ; + return ; +} + +sub permanentflags +{ + my $mysync = shift @ARG ; + + my @lines = @ARG ; + + foreach my $line ( @lines ) { + if ( $line =~ m{\[PERMANENTFLAGS\s\(([^)]+?)\)\]}x ) { + ( $mysync->{ debugflags } or $mysync->{ debug } ) and myprint( "permanentflags: $line" ) ; + my $permanentflags = $1 ; + if ( $permanentflags =~ m{\\\*}x ) + { + $permanentflags = q{} ; + } + return( $permanentflags ) ; + } ; + } + return( q{} ) ; +} + +sub tests_flags_filter +{ + note( 'Entering tests_flags_filter()' ) ; + + ok( '\Seen' eq flags_filter('\Seen', '\Draft \Seen \Answered'), 'flags_filter ' ); + ok( q{} eq flags_filter('\Seen', '\Draft \Answered'), 'flags_filter ' ); + ok( '\Seen' eq flags_filter('\Seen', '\Seen'), 'flags_filter ' ); + ok( '\Seen' eq flags_filter('\Seen', ' \Seen '), 'flags_filter ' ); + ok( '\Seen \Draft' + eq flags_filter('\Seen \Draft', '\Draft \Seen \Answered'), 'flags_filter ' ); + ok( '\Seen \Draft' + eq flags_filter('\Seen \Draft', ' \Draft \Seen \Answered '), 'flags_filter ' ); + + note( 'Leaving tests_flags_filter()' ) ; + return ; +} + +sub flags_filter +{ + my( $flags, $allowed_flags ) = @_ ; + + my @flags = split /\s+/x, $flags ; + my %allowed_flags = map { $_ => 1 } split q{ }, $allowed_flags ; + my @flags_out = map { exists $allowed_flags{$_} ? $_ : () } @flags ; + + my $flags_out = join q{ }, @flags_out ; + + return( $flags_out ) ; +} + +sub tests_flagscase +{ + note( 'Entering tests_flagscase()' ) ; + + ok( '\Seen' eq flagscase( '\Seen' ), 'flagscase: \Seen -> \Seen' ) ; + ok( '\Seen' eq flagscase( '\SEEN' ), 'flagscase: \SEEN -> \Seen' ) ; + + ok( '\Seen \Draft' eq flagscase( '\SEEN \DRAFT' ), 'flagscase: \SEEN \DRAFT -> \Seen \Draft' ) ; + ok( '\Draft \Seen' eq flagscase( '\DRAFT \SEEN' ), 'flagscase: \DRAFT \SEEN -> \Draft \Seen' ) ; + + ok( '\Draft LALA \Seen' eq flagscase( '\DRAFT LALA \SEEN' ), 'flagscase: \DRAFT LALA \SEEN -> \Draft LALA \Seen' ) ; + ok( '\Draft lala \Seen' eq flagscase( '\DRAFT lala \SEEN' ), 'flagscase: \DRAFT lala \SEEN -> \Draft lala \Seen' ) ; + + note( 'Leaving tests_flagscase()' ) ; + return ; +} + +sub flagscase +{ + my $flags = shift @ARG ; + + my @flags = split /\s+/x, $flags ; + my %rfc_flags = map { $_ => 1 } split q{ }, '\Answered \Flagged \Deleted \Seen \Draft' ; + my @flags_out = map { exists $rfc_flags{ ucsecond( lc $_ ) } ? ucsecond( lc $_ ) : $_ } @flags ; + + my $flags_out = join q{ }, @flags_out ; + + return( $flags_out ) ; +} + + + +sub tests_flags_for_host2 +{ + note( 'Entering tests_flags_for_host2()' ) ; + + is( undef, flags_for_host2( ), 'flags_for_host2: no args => undef' ) ; + + my $mysync ; + is( undef, flags_for_host2( $mysync ), 'flags_for_host2: undef => undef' ) ; + + $mysync = { } ; + is( undef, flags_for_host2( $mysync ), 'flags_for_host2: nothing => undef' ) ; + + is( q{}, flags_for_host2( $mysync, '' ), 'flags_for_host2: no flags => empty string' ) ; + + is( q{}, flags_for_host2( $mysync, '\Recent' ), 'flags_for_host2: \Recent => empty string' ) ; + + is( q{\Seen}, flags_for_host2( $mysync, '\Recent \Seen' ), 'flags_for_host2: \Recent \Seen => \Seen' ) ; + + is( q{\Deleted \Seen}, flags_for_host2( $mysync, '\Deleted \Recent \Seen' ), 'flags_for_host2: \Deleted \Recent \Seen => \Deleted \Seen' ) ; + + $mysync->{ flagscase } = 0 ; + is( q{\DELETED \Seen}, flags_for_host2( $mysync, '\DELETED \Seen' ), 'flags_for_host2: flagscase = 0 \DELETED \Seen => \DELETED \Seen' ) ; + + $mysync->{ flagscase } = 1 ; + is( q{\Deleted \Seen}, flags_for_host2( $mysync, '\DELETED \Seen' ), 'flags_for_host2: flagscase = 1 \DELETED \Seen => \Deleted \Seen' ) ; + + $mysync->{ filterflags } = 0 ; + is( q{\Seen \Blabla}, flags_for_host2( $mysync, '\Seen \Blabla', '\Seen \Junk' ), 'flags_for_host2: filterflags = 0 \Seen \Blabla among \Seen \Junk => \Seen \Blabla' ) ; + + $mysync->{ filterflags } = 1 ; + is( q{\Seen}, flags_for_host2( $mysync, '\Seen \Blabla', '\Seen \Junk' ), 'flags_for_host2: filterflags = 1 \Seen \Blabla among \Seen \Junk => \Seen' ) ; + + $mysync->{ filterflags } = 1 ; + is( q{\Seen \Blabla}, flags_for_host2( $mysync, '\Seen \Blabla', '' ), 'flags_for_host2: filterflags = 1 \Seen \Blabla among "" => \Seen \Blabla' ) ; + + + note( 'Leaving tests_flags_for_host2()' ) ; + return ; +} + + + + +sub flags_for_host2 +{ + my $mysync = shift @ARG ; + my $h1_flags = shift @ARG ; + my $permanentflags2 = shift @ARG ; + + if ( ! all_defined( $mysync, $h1_flags ) ) { return ; } ; + + # RFC 2060: This flag can not be altered by any client + $h1_flags =~ s@\\Recent\s?@@xgi ; + + my $h1_flags_re ; + if ( $mysync->{ regexflag } and defined( $h1_flags_re = regexflags( $mysync, $h1_flags ) ) ) { + $h1_flags = $h1_flags_re ; + } + + if ( $mysync->{ flagscase } ) + { + $h1_flags = flagscase( $h1_flags ) ; + } + + if ( $permanentflags2 and $mysync->{ filterflags } ) + { + $h1_flags = flags_filter( $h1_flags, $permanentflags2 ) ; + } + + return( $h1_flags ) ; +} + + + +sub ucsecond +{ + my $string = shift @ARG ; + my $output ; + + return( $string ) if ( 1 >= length $string ) ; + + $output = ( substr( $string, 0, 1) ) . ( uc substr $string, 1, 1 ) . ( substr $string, 2 ) ; + #myprint( "UUU $string -> $output\n" ) ; + return( $output ) ; +} + + +sub tests_ucsecond +{ + note( 'Entering tests_ucsecond()' ) ; + + ok( 'aBcde' eq ucsecond( 'abcde' ), 'ucsecond: abcde -> aBcde' ) ; + ok( 'ABCDE' eq ucsecond( 'ABCDE' ), 'ucsecond: ABCDE -> ABCDE' ) ; + ok( 'ABCDE' eq ucsecond( 'AbCDE' ), 'ucsecond: AbCDE -> ABCDE' ) ; + ok( 'ABCde' eq ucsecond( 'AbCde' ), 'ucsecond: AbCde -> ABCde' ) ; + ok( 'A' eq ucsecond( 'A' ), 'ucsecond: A -> A' ) ; + ok( 'AB' eq ucsecond( 'Ab' ), 'ucsecond: Ab -> AB' ) ; + ok( '\B' eq ucsecond( '\b' ), 'ucsecond: \b -> \B' ) ; + ok( '\Bcde' eq ucsecond( '\bcde' ), 'ucsecond: \bcde -> \Bcde' ) ; + + note( 'Leaving tests_ucsecond()' ) ; + return ; +} + + +sub select_msgs +{ + my ( $imap, $msgs_all_hash_ref, $search_cmd, $abletosearch, $folder ) = @_ ; + my ( @msgs ) ; + + if ( $abletosearch ) { + @msgs = select_msgs_by_search( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ; + }else{ + @msgs = select_msgs_by_fetch( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ; + } + return( @msgs ) ; + +} + +sub select_msgs_by_search +{ + my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ; + my ( @msgs, @msgs_all ) ; + + # Need to have the whole list in msgs_all_hash_ref + # without calling messages() several times. + # Need all messages list to avoid deleting useful cache part + # in case of --search or --minage or --maxage + + if ( ( defined $msgs_all_hash_ref and $sync->{ usecache } ) + or ( not defined $maxage and not defined $minage and not defined $search_cmd ) + ) { + + $debugdev and myprint( "Calling messages()\n" ) ; + @msgs_all = $imap->messages( ) ; + + return if ( $#msgs_all == 0 && !defined $msgs_all[0] ) ; + + if ( defined $msgs_all_hash_ref ) { + @{ $msgs_all_hash_ref }{ @msgs_all } = () ; + } + # return all messages + if ( not defined $maxage and not defined $minage and not defined $search_cmd ) { + return( @msgs_all ) ; + } + } + + if ( defined $search_cmd ) { + @msgs = $imap->search( $search_cmd ) ; + return( @msgs ) ; + } + + # we are here only if $maxage or $minage is defined + @msgs = select_msgs_by_age( $imap ) ; + return( @msgs ); +} + + +sub select_msgs_by_fetch +{ + my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ; + my ( @msgs, @msgs_all, %fetch ) ; + + # Need to have the whole list in msgs_all_hash_ref + # without calling messages() several times. + # Need all messages list to avoid deleting useful cache part + # in case of --search or --minage or --maxage + + + $debugdev and myprint( "Calling fetch_hash()\n" ) ; + my $fetch_hash_uids = $fetch_hash_set || "1:*" ; + %fetch = %{$imap->fetch_hash( $fetch_hash_uids, 'INTERNALDATE' ) } ; + + @msgs_all = sort { $a <=> $b } keys %fetch ; + $debugdev and myprint( "Done fetch_hash()\n" ) ; + + return if ( $#msgs_all == 0 && !defined $msgs_all[0] ) ; + + if ( defined $msgs_all_hash_ref ) { + @{ $msgs_all_hash_ref }{ @msgs_all } = () ; + } + # return all messages + if ( not defined $maxage and not defined $minage and not defined $search_cmd ) { + return( @msgs_all ) ; + } + + if ( defined $search_cmd ) { + myprint( "Warning: strange to see --search with --noabletosearch, an error can happen\n" ) ; + @msgs = $imap->search( $search_cmd ) ; + return( @msgs ) ; + } + + # we are here only if $maxage or $minage is defined + my( @max, @min, $maxage_epoch, $minage_epoch ) ; + if ( defined $maxage ) { $maxage_epoch = $timestart_int - $NB_SECONDS_IN_A_DAY * $maxage ; } + if ( defined $minage ) { $minage_epoch = $timestart_int - $NB_SECONDS_IN_A_DAY * $minage ; } + foreach my $msg ( @msgs_all ) { + my $idate = $fetch{ $msg }->{'INTERNALDATE'} ; + #myprint( "$idate\n" ) ; + if ( defined $maxage and ( epoch( $idate ) >= $maxage_epoch ) ) { + push @max, $msg ; + } + if ( defined $minage and ( epoch( $idate ) <= $minage_epoch ) ) { + push @min, $msg ; + } + } + @msgs = msgs_from_maxmin( \@max, \@min ) ; + return( @msgs ) ; +} + +sub select_msgs_by_age +{ + my( $imap ) = @_ ; + + my( @max, @min, @msgs, @inter, @union ) ; + + if ( defined $maxage ) { + @max = $imap->sentsince( $timestart_int - $NB_SECONDS_IN_A_DAY * $maxage ) ; + } + if ( defined $minage ) { + @min = $imap->sentbefore( $timestart_int - $NB_SECONDS_IN_A_DAY * $minage ) ; + } + + @msgs = msgs_from_maxmin( \@max, \@min ) ; + return( @msgs ) ; +} + +sub msgs_from_maxmin +{ + my( $max_ref, $min_ref ) = @_ ; + my( @max, @min, @msgs, @inter, @union ) ; + + @max = @{ $max_ref } ; + @min = @{ $min_ref } ; + + SWITCH: { + if ( not ( defined $minage or defined $maxage ) ) + { + return ; + } + unless( defined $minage ) { @msgs = @max ; last SWITCH } ; + unless( defined $maxage ) { @msgs = @min ; last SWITCH } ; + my ( %union, %inter ) ; + foreach my $m ( @min, @max ) { $union{ $m }++ && $inter{ $m }++ } + @inter = sort { $a <=> $b } keys %inter ; + @union = sort { $a <=> $b } keys %union ; + # normal case + if ( $minage <= $maxage ) { @msgs = @inter ; last SWITCH } ; + # just exclude messages between + if ( $minage > $maxage ) { @msgs = @union ; last SWITCH } ; + + } + return( @msgs ) ; +} + +sub tests_msgs_from_maxmin +{ + note( 'Entering tests_msgs_from_maxmin()' ) ; + + + my @msgs ; + + # no maxage nor minage + @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; + is_deeply( [ ], \@msgs , 'msgs_from_maxmin: no maxage nor minage => empty result' ) ; + + # maxage alone + $maxage = $NUMBER_200 ; + @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; + is_deeply( [ '1', '2' ], \@msgs , 'msgs_from_maxmin: maxage++' ) ; + + # maxage > minage -> intersection + $minage = $NUMBER_100 ; + @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; + is_deeply( [ '2' ], \@msgs , 'msgs_from_maxmin: -maxage++minage-' ) ; + + # maxage < minage -> union + $minage = $NUMBER_300 ; + @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; + is_deeply( [ '1', '2', '3' ], \@msgs, 'msgs_from_maxmin: ++maxage-minage++' ) ; + + + # minage alone + $maxage = undef ; + @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; + is_deeply( [ '2', '3' ], \@msgs, 'msgs_from_maxmin: ++minage-' ) ; + + + note( 'Leaving tests_msgs_from_maxmin()' ) ; + return ; +} + +sub tests_info_date_from_uid +{ + note( 'Entering tests_info_date_from_uid()' ) ; + note( 'Leaving tests_info_date_from_uid()' ) ; + + return ; +} + +sub info_date_from_uid +{ + + #my $first_uid = $msgs_all[ 0 ] ; + #my $first_idate = $fetch{ $first_uid }->{'INTERNALDATE'} ; + #my $first_epoch = epoch( $first_idate ) ; + #my $first_days = ( $timestart_int - $first_epoch ) / $NB_SECONDS_IN_A_DAY ; + #myprint( "\nOldest msg has UID $first_uid INTERNALDATE $first_idate EPOCH $first_epoch DAYS AGO $first_days\n" ) ; +} + + +sub lastuid +{ + my $imap = shift @ARG ; + my $folder = shift @ARG ; + my $lastuid_guess = shift @ARG ; + my $lastuid ; + + # rfc3501: The only reliable way to identify recent messages is to + # look at message flags to see which have the \Recent flag + # set, or to do a SEARCH RECENT. + # SEARCH RECENT doesn't work this way on courrier. + + my @recent_messages ; + # SEARCH RECENT for each transfer can be expensive with a big folder + # Call commented for now + #@recent_messages = $imap->recent( ) ; + #myprint( "Recent: @recent_messages\n" ) ; + + my $max_recent ; + $max_recent = max( @recent_messages ) ; + + if ( defined $max_recent and ($lastuid_guess <= $max_recent ) ) { + $lastuid = $max_recent ; + }else{ + $lastuid = $lastuid_guess + } + return( $lastuid ) ; +} + +sub size_filtered +{ + my( $h1_size, $h1_msg, $h1_fold, $h2_fold ) = @_ ; + + $h1_size = 0 if ( ! $h1_size ) ; # null if empty or undef + if ( defined $sync->{ maxsize } and $h1_size > $sync->{ maxsize } ) { + myprint( "msg $h1_fold/$h1_msg skipped ($h1_size exceeds maxsize limit $sync->{ maxsize } bytes)\n" ) ; + $sync->{ total_bytes_skipped } += $h1_size; + $sync->{ nb_msg_skipped } += 1; + return( 1 ) ; + } + if ( defined $minsize and $h1_size <= $minsize ) { + myprint( "msg $h1_fold/$h1_msg skipped ($h1_size smaller than minsize $minsize bytes)\n" ) ; + $sync->{ total_bytes_skipped } += $h1_size; + $sync->{ nb_msg_skipped } += 1; + return( 1 ) ; + } + return( 0 ) ; +} + +sub message_exists +{ + my( $imap, $msg ) = @_ ; + return( 1 ) if not $imap->Uid( ) ; + + my $search_uid ; + ( $search_uid ) = $imap->search( "UID $msg" ) ; + #myprint( "$search ? $msg\n" ) ; + return( 1 ) if ( $search_uid eq $msg ) ; + return( 0 ) ; +} + + +# Globals +# $sync->{ total_bytes_skipped } +# $sync->{ nb_msg_skipped } +# $mysync->{ h1_nb_msg_processed } +sub stats_update_skip_message +{ + my $mysync = shift @ARG ; # to be used + my $h1_size = shift @ARG ; + + $mysync->{ total_bytes_skipped } += $h1_size ; + $mysync->{ nb_msg_skipped } += 1 ; + $mysync->{ h1_nb_msg_processed } +=1 ; + return ; +} + +sub copy_message +{ + # copy + + my ( $mysync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $cache_dir ) = @_ ; + ( $mysync->{ debug } or $mysync->{dry} ) + and myprint( "msg $h1_fold/$h1_msg copying to $h2_fold $mysync->{dry_message} " . eta( $mysync ) . "\n" ) ; + + if ( $mysync->{dry1} ) + { + $mysync->{ h1_nb_msg_processed } +=1 ; + $nb_msg_skipped_dry_mode += 1 ; + return ; + } + + my $h1_size = $h1_fir_ref->{$h1_msg}->{'RFC822.SIZE'} || 0 ; + my $h1_flags = $h1_fir_ref->{$h1_msg}->{'FLAGS'} || q{} ; + my $h1_idate = $h1_fir_ref->{$h1_msg}->{'INTERNALDATE'} || q{} ; + + + if ( size_filtered( $h1_size, $h1_msg, $h1_fold, $h2_fold ) ) { + $mysync->{ h1_nb_msg_processed } +=1 ; + return ; + } + + debugsleep( $mysync ) ; + myprint( "- msg $h1_fold/$h1_msg S[$h1_size] F[$h1_flags] I[$h1_idate] has RFC822.SIZE null!\n" ) if ( ! $h1_size ) ; + + if ( $checkmessageexists and not message_exists( $mysync->{imap1}, $h1_msg ) ) { + stats_update_skip_message( $mysync, $h1_size ) ; + return ; + } + myprint( debugmemory( $mysync, " at C1" ) ) ; + + my ( $string, $string_len ) ; + ( $string_len ) = message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, \$string ) ; + + myprint( debugmemory( $mysync, " at C2" ) ) ; + + # not defined or empty $string + if ( ( not $string ) or ( not $string_len ) ) { + myprint( "- msg $h1_fold/$h1_msg skipped.\n" ) ; + stats_update_skip_message( $mysync, $h1_size ) ; + return ; + } + + # Lines too long (or not enough) => do no copy or fix + if ( ( defined $maxlinelength ) or ( defined $minmaxlinelength ) ) { + $string = linelengthstuff( $string, $h1_fold, $h1_msg, $string_len, $h1_size, $h1_flags, $h1_idate ) ; + if ( not defined $string ) { + stats_update_skip_message( $mysync, $h1_size ) ; + return ; + } + } + + my $h1_date = date_for_host2( $h1_msg, $h1_idate ) ; + + ( $mysync->{ debug } or $mysync->{ debugflags } ) and + myprint( "Host1: flags init msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ) ; + + $h1_flags = flags_for_host2( $mysync, $h1_flags, $mysync->{ permanentflags2 } ) ; + + ( $mysync->{ debug } or $mysync->{ debugflags } ) and + myprint( "Host1: flags filt msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ) ; + + $h1_date = undef if ( $h1_date eq q{} ) ; + + my $new_id = append_message_on_host2( $mysync, \$string, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) ; + + + + if ( $new_id and $syncflagsaftercopy ) { + sync_flags_after_copy( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $new_id ) ; + } + + myprint( debugmemory( $mysync, " at C3" ) ) ; + + return $new_id ; +} + + + +sub linelengthstuff +{ + my( $string, $h1_fold, $h1_msg, $string_len, $h1_size, $h1_flags, $h1_idate ) = @_ ; + my $maxlinelength_string = max_line_length( $string ) ; + $debugmaxlinelength and myprint( "msg $h1_fold/$h1_msg maxlinelength: $maxlinelength_string\n" ) ; + + if ( ( defined $minmaxlinelength ) and ( $maxlinelength_string <= $minmaxlinelength ) ) { + my $subject = subject( $string ) ; + $debugdev and myprint( "- msg $h1_fold/$h1_msg skipped S[$h1_size] F[$h1_flags] I[$h1_idate] " + . "(Subject:[$subject]) (max line length under minmaxlinelength $minmaxlinelength bytes)\n" ) ; + return ; + } + + if ( ( defined $maxlinelength ) and ( $maxlinelength_string > $maxlinelength ) ) { + my $subject = subject( $string ) ; + if ( $maxlinelengthcmd ) { + $string = pipemess( $string, $maxlinelengthcmd ) ; + # string undef means something was bad. + if ( not ( defined $string ) ) { + myprint( "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate] " + . "(Subject:[$subject]) could not be successfully transformed by --maxlinelengthcmd option\n" ) ; + return ; + }else{ + return $string ; + } + } + myprint( "- msg $h1_fold/$h1_msg skipped S[$h1_size] F[$h1_flags] I[$h1_idate] " + . "(Subject:[$subject]) (line length exceeds maxlinelength $maxlinelength bytes)\n" ) ; + return ; + } + return $string ; +} + + +sub message_for_host2 +{ + +# global variable list: +# @skipmess +# @regexmess +# @pipemess +# $debugcontent +# $debug +# +# API current +# +# at failure: +# * return nothing ( will then be undef or () ) +# * $string_ref content is undef or empty +# at success: +# * return string length ($string_ref content length) +# * $string_ref content filled with message + +# API future +# +# + my ( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ) = @_ ; + + # abort when missing a parameter + if ( ( ! $mysync ) or ( ! $h1_msg ) or ( ! $h1_fold ) or ( ! defined $h1_size ) + or ( ! defined $h1_flags) or ( ! defined $h1_idate ) + or ( ! $h1_fir_ref) or ( ! $string_ref ) ) + { + return ; + } + + myprint( debugmemory( $mysync, " at M1" ) ) ; + + + my $string_ok = $mysync->{imap1}->message_to_file( $string_ref, $h1_msg ) ; + + myprint( debugmemory( $mysync, " at M2" ) ) ; + + my $string_len = length_ref( $string_ref ) ; + + + unless ( defined $string_ok and $string_len ) { + # undef or 0 length + my $error = join q{}, + "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate] could not be fetched: ", + $mysync->{imap1}->LastError || q{}, "\n" ; + errors_incr( $mysync, $error ) ; + $mysync->{ h1_nb_msg_processed } +=1 ; + return ; + } + + if ( @skipmess ) { + my $match = skipmess( ${ $string_ref } ) ; + # string undef means the eval regex was bad. + if ( not ( defined $match ) ) { + myprint( + "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]" + . " could not be skipped by --skipmess option, bad regex\n" ) ; + return ; + } + if ( $match ) { + my $subject = subject( ${ $string_ref } ) ; + myprint( "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]" + . " (Subject:[$subject]) skipped by --skipmess\n" ) ; + return ; + } + } + + if ( @regexmess ) { + ${ $string_ref } = regexmess( ${ $string_ref } ) ; + # string undef means the eval regex was bad. + if ( not ( defined ${ $string_ref } ) ) { + myprint( + "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]" + . " could not be transformed by --regexmess\n" ) ; + return ; + } + } + + if ( @pipemess ) { + ${ $string_ref } = pipemess( ${ $string_ref }, @pipemess ) ; + # string undef means something was bad. + if ( not ( defined ${ $string_ref } ) ) { + myprint( + "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]" + . " could not be successfully transformed by --pipemess option\n" ) ; + return ; + } + } + + if ( $mysync->{addheader} and defined $h1_fir_ref->{$h1_msg}->{'NO_HEADER'} ) { + my $header = add_header( $h1_msg ) ; + $mysync->{ debug } and myprint( "msg $h1_fold/$h1_msg adding custom header [$header]\n" ) ; + ${ $string_ref } = $header . "\r\n" . ${ $string_ref } ; + } + + if ( ( defined $mysync->{ truncmess } ) and is_integer( $mysync->{ truncmess } ) ) + { + ${ $string_ref } = truncmess( ${ $string_ref }, $mysync->{ truncmess } ) ; + } + + $string_len = length_ref( $string_ref ) ; + + $mysync->{ debugcontent } and myprint( debugcontent( $mysync, $string_ref ) ) ; + + myprint( debugmemory( $mysync, " at M3" ) ) ; + + return $string_len ; +} + +sub tests_debugcontent +{ + note( 'Entering tests_debugcontent()' ) ; + + is( undef, debugcontent( ), 'debugcontent: no args => undef' ) ; + my $mysync = { } ; + is( undef, debugcontent( $mysync ), 'debugcontent: undef => undef' ) ; + is( undef, debugcontent( $mysync, 'mm' ), 'debugcontent: undef, mm => undef' ) ; + #my $string_ref = \'zztop' ; + my $string = '================================================================================ +F message content begin next line (2 characters long) +mm +F message content ended on previous line +================================================================================ +' ; + is( $string, debugcontent( $mysync, \'mm' ), 'debugcontent: undef, mm => mm' ) ; + + note( 'Leaving tests_debugcontent()' ) ; + return ; +} + +sub debugcontent +{ + my $mysync = shift @ARG ; + if ( ! defined $mysync ) { return ; } + + my $string_ref = shift @ARG ; + if ( ! defined $string_ref ) { return ; } + if ( 'SCALAR' ne ref( $string_ref ) ) { return ; } + + my $string_len = length_ref( $string_ref ) ; + + my $string = join( '', + q{=} x $STD_CHAR_PER_LINE, "\n", + "F message content begin next line ($string_len characters long)\n", + ${ $string_ref }, + "\nF message content ended on previous line\n", q{=} x $STD_CHAR_PER_LINE, "\n", + ) ; + + return $string ; +} + + + + + +sub tests_truncmess +{ + note( 'Entering tests_truncmess()' ) ; + + is( undef, truncmess( ), 'truncmess: no args => undef' ) ; + is( 'abc', truncmess( 'abc' ), 'truncmess: abc => abc' ) ; + is( 'ab', truncmess( 'abc', 2 ), 'truncmess: abc 2 => ab' ) ; + is( 'abc', truncmess( 'abc', 3 ), 'truncmess: abc 3 => abc' ) ; + is( 'abc', truncmess( 'abc', 4 ), 'truncmess: abc 4 => abc' ) ; + is( '12345', truncmess( "123456789\n", 5 ), 'truncmess: "123456789\n", 5 => 12345' ) ; + is( "123456789\n" x 5000, truncmess( "123456789\n" x 100000, 50000 ), 'truncmess: "123456789\n" x 100000, 50000 => "123456789\n" x 5000' ) ; + note( 'Leaving tests_truncmess()' ) ; + return ; +} + +sub truncmess +{ + my $string = shift @ARG ; + my $length = shift @ARG ; + + if ( not defined $string ) { return ; } + if ( not defined $length ) { return $string ; } + + $string = substr $string, 0, $length ; + return $string ; +} + +sub tests_message_for_host2 +{ + note( 'Entering tests_message_for_host2()' ) ; + + + my ( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ) ; + + is( undef, message_for_host2( ), q{message_for_host2: no args} ) ; + is( undef, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), q{message_for_host2: undef args} ) ; + + require_ok( "Test::MockObject" ) ; + my $imapT = Test::MockObject->new( ) ; + $mysync->{imap1} = $imapT ; + my $string ; + + $h1_msg = 1 ; + $h1_fold = 'FoldFoo'; + $h1_size = 9 ; + $h1_flags = q{} ; + $h1_idate = '10-Jul-2015 09:00:00 +0200' ; + $h1_fir_ref = {} ; + $string_ref = \$string ; + $imapT->mock( 'message_to_file', + sub { + my ( $imap, $mystring_ref, $msg ) = @_ ; + ${$mystring_ref} = 'blablabla' ; + return length ${$mystring_ref} ; + } + ) ; + is( 9, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), + q{message_for_host2: msg 1 == "blablabla", length} ) ; + is( 'blablabla', $string, q{message_for_host2: msg 1 == "blablabla", value} ) ; + + # so far so good + # now the --pipemess stuff + + SKIP: { + Readonly my $NB_WIN_tests_message_for_host2 => 0 ; + skip( 'Not on MSWin32', $NB_WIN_tests_message_for_host2 ) if ('MSWin32' ne $OSNAME) ; + # Windows + # "type" command does not accept redirection of STDIN with < + # "sort" does + + } ; + + SKIP: { + Readonly my $NB_UNX_tests_message_for_host2 => 6 ; + skip( 'Not on Unix', $NB_UNX_tests_message_for_host2 ) if ('MSWin32' eq $OSNAME) ; + # Unix + + # no change by cat + @pipemess = ( 'cat' ) ; + is( 9, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), + q{message_for_host2: --pipemess 'cat', length} ) ; + is( 'blablabla', $string, q{message_for_host2: --pipemess 'cat', value} ) ; + + + # failure by false + @pipemess = ( 'false' ) ; + is( undef, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), + q{message_for_host2: --pipemess 'false', length} ) ; + is( undef, $string, q{message_for_host2: --pipemess 'false', value} ) ; + + # failure by true since no output + @pipemess = ( 'true' ) ; + is( undef, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), + q{message_for_host2: --pipemess 'true', length} ) ; + is( undef, $string, q{message_for_host2: --pipemess 'true', value} ) ; + } + + undef @pipemess ; + note( 'Leaving tests_message_for_host2()' ) ; + return ; +} + +sub tests_labels_remove_subfolder1 +{ + note( 'Entering tests_labels_remove_subfolder1()' ) ; + is( undef, labels_remove_subfolder1( ), 'labels_remove_subfolder1: no parameters => undef' ) ; + is( 'Blabla', labels_remove_subfolder1( 'Blabla' ), 'labels_remove_subfolder1: one parameter Blabla => Blabla' ) ; + is( 'Blan blue', labels_remove_subfolder1( 'Blan blue' ), 'labels_remove_subfolder1: one parameter Blan blue => Blan blue' ) ; + is( '\Bla "Blan blan" Blabla', labels_remove_subfolder1( '\Bla "Blan blan" Blabla' ), + 'labels_remove_subfolder1: one parameter \Bla "Blan blan" Blabla => \Bla "Blan blan" Blabla' ) ; + + is( 'Bla', labels_remove_subfolder1( 'Subf/Bla', 'Subf' ), 'labels_remove_subfolder1: Subf/Bla Subf => "Bla"' ) ; + + + is( '"\\\\Bla"', labels_remove_subfolder1( '"\\\\Bla"', 'Subf' ), 'labels_remove_subfolder1: "\\\\Bla" Subf => "\\\\Bla"' ) ; + + is( 'Bla Kii', labels_remove_subfolder1( 'Subf/Bla Subf/Kii', 'Subf' ), + 'labels_remove_subfolder1: Subf/Bla Subf/Kii, Subf => "Bla" "Kii"' ) ; + + is( '"\\\\Bla" Kii', labels_remove_subfolder1( '"\\\\Bla" Subf/Kii', 'Subf' ), + 'labels_remove_subfolder1: "\\\\Bla" Subf/Kii Subf => "\\\\Bla" Kii' ) ; + + is( '"Blan blan"', labels_remove_subfolder1( '"Subf/Blan blan"', 'Subf' ), + 'labels_remove_subfolder1: "Subf/Blan blan" Subf => "Blan blan"' ) ; + + is( '"\\\\Loo" "Blan blan" Kii', labels_remove_subfolder1( '"\\\\Loo" "Subf/Blan blan" Subf/Kii', 'Subf' ), + 'labels_remove_subfolder1: "\\\\Loo" "Subf/Blan blan" Subf/Kii + Subf => "\\\\Loo" "Blan blan" Kii' ) ; + + is( '"\\\\Inbox"', labels_remove_subfolder1( 'Subf/INBOX', 'Subf' ), + 'labels_remove_subfolder1: Subf/INBOX + Subf => "\\\\Inbox"' ) ; + + is( '"\\\\Loo" "Blan blan" Kii "\\\\Inbox"', labels_remove_subfolder1( '"\\\\Loo" "Subf/Blan blan" Subf/Kii Subf/INBOX', 'Subf' ), + 'labels_remove_subfolder1: "\\\\Loo" "Subf/Blan blan" Subf/Kii Subf/INBOX + Subf => "\\\\Loo" "Blan blan" Kii "\\\\Inbox"' ) ; + + + note( 'Leaving tests_labels_remove_subfolder1()' ) ; + return ; +} + + + +sub labels_remove_subfolder1 +{ + my $labels = shift @ARG ; + my $subfolder1 = shift @ARG ; + + if ( not defined $labels ) { return ; } + if ( not defined $subfolder1 ) { return $labels ; } + + my @labels = quotewords('\s+', 1, $labels ) ; + #myprint( "@labels\n" ) ; + my @labels_subfolder2 ; + + foreach my $label ( @labels ) + { + if ( $label =~ m{zzzzzzzzzz} ) + { + # \Seen \Deleted ... stay the same + push @labels_subfolder2, $label ; + } + else + { + # Remove surrounding quotes if any, to add them again in case of space + $label = join( q{}, quotewords('\s+', 0, $label ) ) ; + $label =~ s{$subfolder1/?}{} ; + if ( 'INBOX' eq $label ) + { + push @labels_subfolder2, q{"\\\\Inbox"} ; + } + elsif ( $label =~ m{\\} ) + { + push @labels_subfolder2, qq{"\\$label"} ; + } + elsif ( $label =~ m{ } ) + { + push @labels_subfolder2, qq{"$label"} ; + } + else + { + push @labels_subfolder2, $label ; + } + } + } + + my $labels_subfolder2 = join( ' ', sort uniq( @labels_subfolder2 ) ) ; + + return $labels_subfolder2 ; +} + +sub tests_labels_remove_special +{ + note( 'Entering tests_labels_remove_special()' ) ; + + is( undef, labels_remove_special( ), 'labels_remove_special: no parameters => undef' ) ; + is( q{}, labels_remove_special( q{} ), 'labels_remove_special: empty string => empty string' ) ; + is( q{}, labels_remove_special( '"\\\\Inbox"' ), 'labels_remove_special:"\\\\Inbox" => empty string' ) ; + is( q{}, labels_remove_special( '"\\\\Inbox" "\\\\Starred"' ), 'labels_remove_special:"\\\\Inbox" "\\\\Starred" => empty string' ) ; + is( 'Bar Foo', labels_remove_special( 'Foo Bar' ), 'labels_remove_special:Foo Bar => Bar Foo' ) ; + is( 'Bar Foo', labels_remove_special( 'Foo Bar "\\\\Inbox"' ), 'labels_remove_special:Foo Bar "\\\\Inbox" => Bar Foo' ) ; + note( 'Leaving tests_labels_remove_special()' ) ; + return ; +} + + + + +sub labels_remove_special +{ + my $labels = shift @ARG ; + + if ( not defined $labels ) { return ; } + + my @labels = quotewords('\s+', 1, $labels ) ; + myprint( "labels before remove_non_folded: @labels\n" ) ; + my @labels_remove_special ; + + foreach my $label ( @labels ) + { + if ( $label =~ m{^\"\\\\} ) + { + # not kept + } + else + { + push @labels_remove_special, $label ; + } + } + + my $labels_remove_special = join( ' ', sort @labels_remove_special ) ; + + return $labels_remove_special ; +} + + +sub tests_labels_add_subfolder2 +{ + note( 'Entering tests_labels_add_subfolder2()' ) ; + is( undef, labels_add_subfolder2( ), 'labels_add_subfolder2: no parameters => undef' ) ; + is( 'Blabla', labels_add_subfolder2( 'Blabla' ), 'labels_add_subfolder2: one parameter Blabla => Blabla' ) ; + is( 'Blan blue', labels_add_subfolder2( 'Blan blue' ), 'labels_add_subfolder2: one parameter Blan blue => Blan blue' ) ; + is( '\Bla "Blan blan" Blabla', labels_add_subfolder2( '\Bla "Blan blan" Blabla' ), + 'labels_add_subfolder2: one parameter \Bla "Blan blan" Blabla => \Bla "Blan blan" Blabla' ) ; + + is( 'Subf/Bla', labels_add_subfolder2( 'Bla', 'Subf' ), 'labels_add_subfolder2: Bla Subf => "Subf/Bla"' ) ; + + + is( 'Subf/\Bla', labels_add_subfolder2( '\\\\Bla', 'Subf' ), 'labels_add_subfolder2: \Bla Subf => \Bla' ) ; + + is( 'Subf/Bla Subf/Kii', labels_add_subfolder2( 'Bla Kii', 'Subf' ), + 'labels_add_subfolder2: Bla Kii Subf => "Subf/Bla" "Subf/Kii"' ) ; + + is( 'Subf/Kii Subf/\Bla', labels_add_subfolder2( '\\\\Bla Kii', 'Subf' ), + 'labels_add_subfolder2: \Bla Kii Subf => \Bla Subf/Kii' ) ; + + is( '"Subf/Blan blan"', labels_add_subfolder2( '"Blan blan"', 'Subf' ), + 'labels_add_subfolder2: "Blan blan" Subf => "Subf/Blan blan"' ) ; + + is( '"Subf/Blan blan" Subf/Kii Subf/\Loo', labels_add_subfolder2( '\\\\Loo "Blan blan" Kii', 'Subf' ), + 'labels_add_subfolder2: \Loo "Blan blan" Kii + Subf => "Subf/Blan blan" Subf/Kii Subf/\Loo' ) ; + + # "\\Inbox" is special, add to subfolder INBOX also because Gmail will but ... + is( '"Subf/\\\\Inbox" Subf/INBOX', labels_add_subfolder2( '"\\\\Inbox"', 'Subf' ), + 'labels_add_subfolder2: "\\\\Inbox" Subf => "Subf/\\\\Inbox" Subf/INBOX' ) ; + + # but not with INBOX folder + is( '"Subf/\\\\Inbox"', labels_add_subfolder2( '"\\\\Inbox"', 'Subf', 'INBOX' ), + 'labels_add_subfolder2: "\\\\Inbox" Subf INBOX => "Subf/\\\\Inbox"' ) ; + + # two times => one time + is( '"Subf/\\\\Inbox" Subf/INBOX', labels_add_subfolder2( '"\\\\Inbox" "\\\\Inbox"', 'Subf' ), + 'labels_add_subfolder2: "\\\\Inbox" "\\\\Inbox" Subf => "Subf/\\\\Inbox"' ) ; + + is( '"Subf/\\\\Starred"', labels_add_subfolder2( '"\\\\Starred"', 'Subf' ), + 'labels_add_subfolder2: "\\\\Starred" Subf => "Subf/\\\\Starred"' ) ; + + note( 'Leaving tests_labels_add_subfolder2()' ) ; + return ; +} + +sub labels_add_subfolder2 +{ + my $labels = shift @ARG ; + my $subfolder2 = shift @ARG ; + my $h1_folder = shift || q{} ; + + if ( not defined $labels ) { return ; } + if ( not defined $subfolder2 ) { return $labels ; } + + # Isn't it messy? + if ( 'INBOX' eq $h1_folder ) + { + $labels .= ' "\\\\Inbox"' ; + } + + my @labels = uniq( quotewords('\s+', 1, $labels ) ) ; + myprint( "labels before subfolder2: @labels\n" ) ; + my @labels_subfolder2 ; + + + foreach my $label ( @labels ) + { + # Isn't it more messy? + if ( ( q{"\\\\Inbox"} eq $label ) and ( 'INBOX' ne $h1_folder ) ) + { + if ( $subfolder2 =~ m{ } ) + { + push @labels_subfolder2, qq{"$subfolder2/INBOX"} ; + } + else + { + push @labels_subfolder2, "$subfolder2/INBOX" ; + } + } + if ( $label =~ m{^\"\\\\} ) + { + # \Seen \Deleted ... stay the same + #push @labels_subfolder2, $label ; + # Remove surrounding quotes if any, to add them again + $label = join( q{}, quotewords('\s+', 0, $label ) ) ; + push @labels_subfolder2, qq{"$subfolder2/\\$label"} ; + + } + else + { + # Remove surrounding quotes if any, to add them again in case of space + $label = join( q{}, quotewords('\s+', 0, $label ) ) ; + if ( $label =~ m{ } ) + { + push @labels_subfolder2, qq{"$subfolder2/$label"} ; + } + else + { + push @labels_subfolder2, "$subfolder2/$label" ; + } + } + } + + my $labels_subfolder2 = join( ' ', sort @labels_subfolder2 ) ; + + return $labels_subfolder2 ; +} + +sub tests_labels +{ + note( 'Entering tests_labels()' ) ; + + is( undef, labels( ), 'labels: no parameters => undef' ) ; + is( undef, labels( undef ), 'labels: undef => undef' ) ; + require_ok( "Test::MockObject" ) ; + my $myimap = Test::MockObject->new( ) ; + + $myimap->mock( 'fetch_hash', + sub { + return( + { '1' => { + 'X-GM-LABELS' => '\Seen Blabla' + } + } + ) ; + } + ) ; + $myimap->mock( 'Debug' , sub { } ) ; + $myimap->mock( 'Unescape', sub { return Mail::IMAPClient::Unescape( @_ ) } ) ; # real one + + is( undef, labels( $myimap ), 'labels: one parameter => undef' ) ; + is( '\Seen Blabla', labels( $myimap, '1' ), 'labels: $mysync UID_1 => \Seen Blabla' ) ; + + note( 'Leaving tests_labels()' ) ; + return ; +} + +sub labels +{ + my ( $myimap, $uid ) = @ARG ; + + if ( not all_defined( $myimap, $uid ) ) { + return ; + } + + my $hash = $myimap->fetch_hash( [ $uid ], 'X-GM-LABELS' ) ; + + my $labels = $hash->{ $uid }->{ 'X-GM-LABELS' } ; + #$labels = $myimap->Unescape( $labels ) ; + return $labels ; +} + +sub tests_synclabels +{ + note( 'Entering tests_synclabels()' ) ; + + is( undef, synclabels( ), 'synclabels: no parameters => undef' ) ; + is( undef, synclabels( undef ), 'synclabels: undef => undef' ) ; + my $mysync ; + is( undef, synclabels( $mysync ), 'synclabels: var undef => undef' ) ; + + require_ok( "Test::MockObject" ) ; + $mysync = {} ; + + my $myimap1 = Test::MockObject->new( ) ; + $myimap1->mock( 'fetch_hash', + sub { + return( + { '1' => { + 'X-GM-LABELS' => '\Seen Blabla' + } + } + ) ; + } + ) ; + $myimap1->mock( 'Debug', sub { } ) ; + $myimap1->mock( 'Unescape', sub { return Mail::IMAPClient::Unescape( @_ ) } ) ; # real one + + my $myimap2 = Test::MockObject->new( ) ; + + $myimap2->mock( 'store', + sub { + return 1 ; + } + ) ; + + + $mysync->{imap1} = $myimap1 ; + $mysync->{imap2} = $myimap2 ; + + is( undef, synclabels( $mysync ), 'synclabels: fresh $mysync => undef' ) ; + + is( undef, synclabels( $mysync, '1' ), 'synclabels: $mysync UID_1 alone => undef' ) ; + is( 1, synclabels( $mysync, '1', '2' ), 'synclabels: $mysync UID_1 UID_2 => 1' ) ; + + note( 'Leaving tests_synclabels()' ) ; + return ; +} + + +sub synclabels +{ + my( $mysync, $uid1, $uid2 ) = @ARG ; + + if ( not all_defined( $mysync, $uid1, $uid2 ) ) { + return ; + } + my $myimap1 = $mysync->{ 'imap1' } || return ; + my $myimap2 = $mysync->{ 'imap2' } || return ; + + $mysync->{debuglabels} and $myimap1->Debug( 1 ) ; + my $labels1 = labels( $myimap1, $uid1 ) ; + $mysync->{debuglabels} and $myimap1->Debug( 0 ) ; + $mysync->{debuglabels} and myprint( "Host1 labels: $labels1\n" ) ; + + + + if ( $mysync->{ subfolder1 } and $labels1 ) + { + $labels1 = labels_remove_subfolder1( $labels1, $mysync->{ subfolder1 } ) ; + $mysync->{debuglabels} and myprint( "Host1 labels with subfolder1: $labels1\n" ) ; + } + + if ( $mysync->{ subfolder2 } and $labels1 ) + { + $labels1 = labels_add_subfolder2( $labels1, $mysync->{ subfolder2 } ) ; + $mysync->{debuglabels} and myprint( "Host1 labels with subfolder2: $labels1\n" ) ; + } + + my $store ; + if ( $labels1 and not $mysync->{ dry } ) + { + $mysync->{ debuglabels } and $myimap2->Debug( 1 ) ; + $store = $myimap2->store( $uid2, "X-GM-LABELS ($labels1)" ) ; + $mysync->{ debuglabels } and $myimap2->Debug( 0 ) ; + } + return $store ; +} + + +sub tests_resynclabels +{ + note( 'Entering tests_resynclabels()' ) ; + + is( undef, resynclabels( ), 'resynclabels: no parameters => undef' ) ; + is( undef, resynclabels( undef ), 'resynclabels: undef => undef' ) ; + my $mysync ; + is( undef, resynclabels( $mysync ), 'resynclabels: var undef => undef' ) ; + + my ( $h1_fir_ref, $h2_fir_ref ) ; + + $mysync->{ debuglabels } = 1 ; + $h1_fir_ref->{ 11 }->{ 'X-GM-LABELS' } = '\Seen Baa Kii' ; + $h2_fir_ref->{ 22 }->{ 'X-GM-LABELS' } = '\Seen Baa Kii' ; + + # labels are equal + is( 1, resynclabels( $mysync, 11, 22, $h1_fir_ref, $h2_fir_ref ), + 'resynclabels: $mysync UID_1 UID_2 labels are equal => 1' ) ; + + # labels are different + $h2_fir_ref->{ 22 }->{ 'X-GM-LABELS' } = '\Seen Zuu' ; + require_ok( "Test::MockObject" ) ; + my $myimap2 = Test::MockObject->new( ) ; + $myimap2->mock( 'store', + sub { + return 1 ; + } + ) ; + $myimap2->mock( 'Debug', sub { } ) ; + $mysync->{imap2} = $myimap2 ; + + is( 1, resynclabels( $mysync, 11, 22, $h1_fir_ref, $h2_fir_ref ), + 'resynclabels: $mysync UID_1 UID_2 labels are not equal => store => 1' ) ; + + note( 'Leaving tests_resynclabels()' ) ; + return ; +} + + + +sub resynclabels +{ + my( $mysync, $uid1, $uid2, $h1_fir_ref, $h2_fir_ref, $h1_folder ) = @ARG ; + + if ( not all_defined( $mysync, $uid1, $uid2, $h1_fir_ref, $h2_fir_ref ) ) { + return ; + } + + my $labels1 = $h1_fir_ref->{ $uid1 }->{ 'X-GM-LABELS' } || q{} ; + my $labels2 = $h2_fir_ref->{ $uid2 }->{ 'X-GM-LABELS' } || q{} ; + + if ( $mysync->{ subfolder1 } and $labels1 ) + { + $labels1 = labels_remove_subfolder1( $labels1, $mysync->{ subfolder1 } ) ; + } + + if ( $mysync->{ subfolder2 } and $labels1 ) + { + $labels1 = labels_add_subfolder2( $labels1, $mysync->{ subfolder2 }, $h1_folder ) ; + $labels2 = labels_remove_special( $labels2 ) ; + } + $mysync->{ debuglabels } and myprint( "Host1 labels fixed: $labels1\n" ) ; + $mysync->{ debuglabels } and myprint( "Host2 labels : $labels2\n" ) ; + + my $store ; + if ( $labels1 eq $labels2 ) + { + # no sync needed + $mysync->{ debuglabels } and myprint( "Labels are already equal\n" ) ; + return 1 ; + } + elsif ( not $mysync->{ dry } ) + { + # sync needed + $mysync->{debuglabels} and $mysync->{imap2}->Debug( 1 ) ; + $store = $mysync->{imap2}->store( $uid2, "X-GM-LABELS ($labels1)" ) ; + $mysync->{debuglabels} and $mysync->{imap2}->Debug( 0 ) ; + } + + return $store ; +} + +sub tests_uniq +{ + note( 'Entering tests_uniq()' ) ; + + is( 0, uniq( ), 'uniq: undef => 0' ) ; + is_deeply( [ 'one' ], [ uniq( 'one' ) ], 'uniq: one => one' ) ; + is_deeply( [ 'one' ], [ uniq( 'one', 'one' ) ], 'uniq: one one => one' ) ; + is_deeply( [ 'one', 'two' ], [ uniq( 'one', 'one', 'two', 'one', 'two' ) ], 'uniq: one one two one two => one two' ) ; + note( 'Leaving tests_uniq()' ) ; + return ; +} + +sub uniq +{ + my @list = @ARG ; + my %seen = ( ) ; + my @uniq = ( ) ; + foreach my $item ( @list ) { + if ( ! $seen{ $item } ) { + $seen{ $item } = 1 ; + push( @uniq, $item ) ; + } + } + return @uniq ; +} + + +sub length_ref +{ + my $string_ref = shift @ARG ; + my $string_len = defined ${ $string_ref } ? length( ${ $string_ref } ) : q{} ; # length or empty string + return $string_len ; +} + +sub tests_length_ref +{ + note( 'Entering tests_length_ref()' ) ; + + my $notdefined ; + is( q{}, length_ref( \$notdefined ), q{length_ref: value not defined} ) ; + my $notref ; + is( q{}, length_ref( $notref ), q{length_ref: param not a ref} ) ; + + my $lala = 'lala' ; + is( 4, length_ref( \$lala ), q{length_ref: lala length == 4} ) ; + is( 4, length_ref( \'lili' ), q{length_ref: lili length == 4} ) ; + + note( 'Leaving tests_length_ref()' ) ; + return ; +} + +sub date_for_host2 +{ + my( $h1_msg, $h1_idate ) = @_ ; + + my $h1_date = q{} ; + + if ( $syncinternaldates ) { + $h1_date = $h1_idate ; + $sync->{ debug } and myprint( "internal date from host1: [$h1_date]\n" ) ; + $h1_date = good_date( $h1_date ) ; + $sync->{ debug } and myprint( "internal date from host1: [$h1_date] (fixed)\n" ) ; + } + + if ( $idatefromheader ) { + $h1_date = $sync->{imap1}->get_header( $h1_msg, 'Date' ) ; + $sync->{ debug } and myprint( "header date from host1: [$h1_date]\n" ) ; + $h1_date = good_date( $h1_date ) ; + $sync->{ debug } and myprint( "header date from host1: [$h1_date] (fixed)\n" ) ; + } + + return( $h1_date ) ; +} + + +sub subject +{ + my $string = shift @ARG ; + my $subject = q{} ; + + my $header = extract_header( $string ) ; + + if( $header =~ m/^Subject:[ \t]*([^\n\r]*)\r?$/msx ) { + #myprint( "MMM[$1]\n" ) ; + $subject = $1 ; + } + return( $subject ) ; +} + +sub tests_subject +{ + note( 'Entering tests_subject()' ) ; + + ok( q{} eq subject( q{} ), 'subject: null') ; + is( '', subject( 'Subject:' ), 'Subject:') ; + is( '', subject( "Subject:\r\n" ), 'Subject:\r\n') ; + ok( 'toto le hero' eq subject( 'Subject: toto le hero' ), 'Subject: toto le hero') ; + ok( 'toto le hero' eq subject( 'Subject:toto le hero' ), 'Subject:toto le hero') ; + ok( 'toto le hero' eq subject( "Subject:toto le hero\r\n" ), 'Subject: toto le hero\r\n') ; + + my $MESS ; + $MESS = <<'EOF'; +From: lalala +Subject: toto le hero +Date: zzzzzz + +Boogie boogie +EOF + ok( 'toto le hero' eq subject( $MESS ), 'subject: toto le hero 2') ; + + $MESS = <<'EOF'; +Subject: toto le hero +From: lalala +Date: zzzzzz + +Boogie boogie +EOF + ok( 'toto le hero' eq subject( $MESS ), 'subject: toto le hero 3') ; + + + $MESS = <<'EOF'; +From: lalala +Subject: cuicui +Date: zzzzzz + +Subject: toto le hero +EOF + ok( 'cuicui' eq subject( $MESS ), 'subject: cuicui') ; + + $MESS = <<'EOF'; +From: lalala +Date: zzzzzz + +Subject: toto le hero +EOF + ok( q{} eq subject( $MESS ), 'subject: null but body could') ; + + + $MESS = <<'EOF'; +From: lalala +Subject: +Date: zzzzzz + +Subject: toto le hero +EOF + is( '', subject( $MESS ), 'Subject:') ; + + + + note( 'Leaving tests_subject()' ) ; + return ; +} + + +# GlobVar +# $h2_uidguess +# ... +# +# +sub append_message_on_host2 +{ + my( $mysync, $string_ref, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) = @_ ; + myprint( debugmemory( $mysync, " at A1" ) ) ; + + my $new_id ; + if ( ! $mysync->{dry} ) { + $new_id = $mysync->{imap2}->append_string( $h2_fold, ${ $string_ref }, $h1_flags, $h1_date ) ; + myprint( debugmemory( $mysync, " at A2" ) ) ; + if ( ! defined $new_id ){ + my $subject = subject( ${ $string_ref } ) ; + my $error_imap = $mysync->{imap2}->LastError || q{} ; + my $error = "- msg $h1_fold/$h1_msg {$string_len} could not append ( Subject:[$subject], Date:[$h1_date], Size:[$h1_size], Flags:[$h1_flags] ) to folder $h2_fold: $error_imap\n" ; + errors_incr( $mysync, $error ) ; + $mysync->{ h1_nb_msg_processed } +=1 ; + return ; + } + else{ + # good + # $new_id is an id if the IMAP server has the + # UIDPLUS capability else just a ref + if ( $new_id !~ m{^\d+$}x ) { + $new_id = lastuid( $mysync->{imap2}, $h2_fold, $h2_uidguess ) ; + } + if ( $mysync->{ synclabels } ) { synclabels( $mysync, $h1_msg, $new_id ) } + $h2_uidguess += 1 ; + $mysync->{ total_bytes_transferred } += $string_len ; + $mysync->{ nb_msg_transferred } += 1 ; + $mysync->{ h1_nb_msg_processed } +=1 ; + $mysync->{ biggest_message_transferred } = max( $string_len, $mysync->{ biggest_message_transferred } ) ; + + my $time_spent = timesince( $mysync->{begin_transfer_time} ) ; + my $rate = bytes_display_string_bin( $mysync->{total_bytes_transferred} / $time_spent ) ; + my $eta = eta( $mysync ) ; + my $amount_transferred = bytes_display_string_bin( $mysync->{total_bytes_transferred} ) ; + myprintf( "msg %s/%-19s copied to %s/%-10s %.2f msgs/s %s/s %s copied %s\n", + $h1_fold, "$h1_msg {$string_len}", $h2_fold, $new_id, $mysync->{nb_msg_transferred}/$time_spent, $rate, + $amount_transferred, + $eta ); + sleep_if_needed( $mysync ) ; + if ( $sync->{ usecache } and $cacheaftercopy and $new_id =~ m{^\d+$}x ) { + $debugcache and myprint( "touch $cache_dir/${h1_msg}_$new_id\n" ) ; + touch( "$cache_dir/${h1_msg}_$new_id" ) + or croak( "Couldn't touch $cache_dir/${h1_msg}_$new_id" ) ; + } + if ( $mysync->{ delete1 } ) { + delete_message_on_host1( $mysync, $h1_fold, $mysync->{ expungeaftereach }, $h1_msg ) ; + } + #myprint( "PRESS ENTER" ) and my $a = <> ; + + return( $new_id ) ; + } + } + else{ + $nb_msg_skipped_dry_mode += 1 ; + $mysync->{ h1_nb_msg_processed } += 1 ; + } + + return ; +} + + +sub tests_sleep_if_needed +{ + note( 'Entering tests_sleep_if_needed()' ) ; + + is( undef, sleep_if_needed( ), 'sleep_if_needed: no args => undef' ) ; + my $mysync ; + is( undef, sleep_if_needed( $mysync ), 'sleep_if_needed: arg undef => undef' ) ; + + $mysync->{maxbytespersecond} = 1000 ; + is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: maxbytespersecond only => no sleep => 0' ) ; + $mysync->{begin_transfer_time} = time ; # now + is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: begin_transfer_time now => no sleep => 0' ) ; + $mysync->{begin_transfer_time} = time - 2 ; # 2 s before + is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 0 => no sleep => 0' ) ; + + $mysync->{total_bytes_transferred} = 2200 ; + $mysync->{begin_transfer_time} = time - 2 ; # 2 s before + is( '0.20', sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 2200 since 2s => sleep 0.2s' ) ; + is( '0', sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 2200 since 2+2 == 4s => no sleep' ) ; + + $mysync->{maxsleep} = 0.1 ; + $mysync->{begin_transfer_time} = time - 2 ; # 2 s before again + is( '0.10', sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 4000 since 2s but maxsleep 0.1s => sleep 0.1s' ) ; + + $mysync->{maxbytesafter} = 4000 ; + $mysync->{begin_transfer_time} = time - 2 ; # 2 s before again + is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: maxbytesafter == total_bytes_transferred => no sleep => 0' ) ; + + note( 'Leaving tests_sleep_if_needed()' ) ; + return ; +} + + +sub sleep_if_needed +{ + my( $mysync ) = shift @ARG ; + + if ( ! $mysync ) { + return ; + } + # No need to go further if there is no limit set + if ( + not ( + $mysync->{maxmessagespersecond} + or $mysync->{maxbytespersecond} + ) + ) { + return ; + } + + $mysync->{maxsleep} = defined $mysync->{maxsleep} ? $mysync->{maxsleep} : $MAX_SLEEP ; + # Must be positive + $mysync->{maxsleep} = max( 0, $mysync->{maxsleep} ) ; + + my $time_spent = timesince( $mysync->{begin_transfer_time} ) ; + my $sleep_max_messages = sleep_max_messages( $mysync->{nb_msg_transferred}, $time_spent, $mysync->{maxmessagespersecond} ) ; + + my $maxbytesafter = $mysync->{maxbytesafter} || 0 ; + my $total_bytes_transferred = $mysync->{total_bytes_transferred} || 0 ; + my $total_bytes_to_consider = $total_bytes_transferred - $maxbytesafter ; + + #myprint( "maxbytesafter:$maxbytesafter\n" ) ; + #myprint( "total_bytes_to_consider:$total_bytes_to_consider\n" ) ; + + my $sleep_max_bytes = sleep_max_bytes( $total_bytes_to_consider, $time_spent, $mysync->{maxbytespersecond} ) ; + my $sleep_max = min( $mysync->{maxsleep}, max( $sleep_max_messages, $sleep_max_bytes ) ) ; + $sleep_max = mysprintf( "%.2f", $sleep_max ) ; # round with 2 decimals. + if ( $sleep_max > 0 ) { + myprint( "sleeping $sleep_max s\n" ) ; + sleep $sleep_max ; + # Slept + return $sleep_max ; + } + # No sleep + return 0 ; +} + +sub sleep_max_messages +{ + # how long we have to sleep to go under max_messages_per_second + my( $nb_msg_transferred, $time_spent, $maxmessagespersecond ) = @_ ; + if ( ( not defined $maxmessagespersecond ) or $maxmessagespersecond <= 0 ) { return( 0 ) } ; + my $sleep = ( $nb_msg_transferred / $maxmessagespersecond ) - $time_spent ; + # the sleep must be positive + return( max( 0, $sleep ) ) ; +} + + +sub tests_sleep_max_messages +{ + note( 'Entering tests_sleep_max_messages()' ) ; + + ok( 0 == sleep_max_messages( 4, 2, undef ), 'sleep_max_messages: maxmessagespersecond = undef') ; + ok( 0 == sleep_max_messages( 4, 2, 0 ), 'sleep_max_messages: maxmessagespersecond = 0') ; + ok( 0 == sleep_max_messages( 4, 2, $MINUS_ONE ), 'sleep_max_messages: maxmessagespersecond = -1') ; + ok( 0 == sleep_max_messages( 4, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max reached') ; + ok( 2 == sleep_max_messages( 8, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max over') ; + ok( 0 == sleep_max_messages( 2, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max not reached') ; + + note( 'Leaving tests_sleep_max_messages()' ) ; + return ; +} + + +sub sleep_max_bytes +{ + # how long we have to sleep to go under max_bytes_per_second + my( $total_bytes_to_consider, $time_spent, $maxbytespersecond ) = @_ ; + $total_bytes_to_consider ||= 0 ; + $time_spent ||= 0 ; + + if ( ( not defined $maxbytespersecond ) or $maxbytespersecond <= 0 ) { return( 0 ) } ; + #myprint( "total_bytes_to_consider:$total_bytes_to_consider\n" ) ; + my $sleep = ( $total_bytes_to_consider / $maxbytespersecond ) - $time_spent ; + # the sleep must be positive + return( max( 0, $sleep ) ) ; +} + + +sub tests_sleep_max_bytes +{ + note( 'Entering tests_sleep_max_bytes()' ) ; + + ok( 0 == sleep_max_bytes( 4000, 2, undef ), 'sleep_max_bytes: maxbytespersecond == undef => sleep 0' ) ; + ok( 0 == sleep_max_bytes( 4000, 2, 0 ), 'sleep_max_bytes: maxbytespersecond = 0 => sleep 0') ; + ok( 0 == sleep_max_bytes( 4000, 2, $MINUS_ONE ), 'sleep_max_bytes: maxbytespersecond = -1 => sleep 0') ; + ok( 0 == sleep_max_bytes( 4000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max reached sharp => sleep 0') ; + ok( 2 == sleep_max_bytes( 8000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max over => sleep a little') ; + ok( 0 == sleep_max_bytes( -8000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max not reached => sleep 0') ; + ok( 0 == sleep_max_bytes( 2000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max not reached => sleep 0') ; + ok( 0 == sleep_max_bytes( -2000, 2, 1000 ), 'sleep_max_bytes: maxbytespersecond = 1k max not reached => sleep 0') ; + + note( 'Leaving tests_sleep_max_bytes()' ) ; + return ; +} + + +sub delete_message_on_host1 +{ + my( $mysync, $h1_fold, $expunge, @h1_msg ) = @_ ; + if ( ! $mysync->{ delete1 } ) { return ; } + if ( ! @h1_msg ) { return ; } + delete_messages_on_any( + $mysync, + $mysync->{ acc1 }, + $mysync->{ imap1 }, + "Host1: $h1_fold", + $expunge, + $split1, + @h1_msg ) ; + return ; +} + +sub tests_operators_and_exclam_precedence +{ + note( 'Entering tests_operators_and_exclam_precedence()' ) ; + + is( 1, ! 0, 'tests_operators_and_exclam_precedence: ! 0 => 1' ) ; + is( "", ! 1, 'tests_operators_and_exclam_precedence: ! 1 => ""' ) ; + is( 1, not( 0 ), 'tests_operators_and_exclam_precedence: not( 0 ) => 1' ) ; + is( "", not( 1 ), 'tests_operators_and_exclam_precedence: not( 1 ) => ""' ) ; + + # I wrote those tests to avoid perlcrit "Mixed high and low-precedence booleans" + # and change sub delete_messages_on_any() but got 4 more warnings... So now commented. + + #is( 0, ( ! 0 and 0 ), 'tests_operators_and_exclam_precedence: ! 0 and 0 ) => 0' ) ; + #is( 1, ( ! 0 and 1 ), 'tests_operators_and_exclam_precedence: ! 0 and 1 ) => 1' ) ; + #is( "", ( ! 1 and 0 ), 'tests_operators_and_exclam_precedence: ! 1 and 0 ) => ""' ) ; + #is( "", ( ! 1 and 1 ), 'tests_operators_and_exclam_precedence: ! 1 and 1 ) => ""' ) ; + + is( 0, ( ! 0 && 0 ), 'tests_operators_and_exclam_precedence: ! 0 && 0 ) => 0' ) ; + is( 1, ( ! 0 && 1 ), 'tests_operators_and_exclam_precedence: ! 0 && 1 ) => 1' ) ; + is( "", ( ! 1 && 0 ), 'tests_operators_and_exclam_precedence: ! 1 && 0 ) => ""' ) ; + is( "", ( ! 1 && 1 ), 'tests_operators_and_exclam_precedence: ! 1 && 1 ) => ""' ) ; + + is( 2, ( ! 0 && 2 ), 'tests_operators_and_exclam_precedence: ! 0 && 2 ) => 1' ) ; + + note( 'Leaving tests_operators_and_exclam_precedence()' ) ; + return ; +} + + +sub delete_messages_on_any +{ + # $acc is not used yet, + # + my( $mysync, $acc, $imap, $hostX_folder, $expunge, $split, @messages ) = @_ ; + my $expunge_message = q{} ; + + my $dry_message = $mysync->{ dry_message } ; + $expunge_message = 'and expunged' if ( $expunge ) ; + # "Host1: msg " + + # $imap->Debug( 1 ) ; + + my @messages_to_mark_deleted = @messages ; + while ( my @messages_part = splice @messages_to_mark_deleted, 0, $split ) + { + foreach my $message ( @messages_part ) + { + myprint( "$hostX_folder/$message marking deleted $expunge_message $dry_message\n" ) ; + } + if ( ! $mysync->{dry} && @messages_part ) + { + my $nb_deleted = $imap->delete_message( $imap->Range( @messages_part ) ) ; + if ( defined $nb_deleted ) + { + # $nb_deleted is not accurate + $acc->{ nb_msg_deleted } += scalar @messages_part ; + } + else + { + my $error_imap = $imap->LastError || q{} ; + my $error = join( q{}, "$hostX_folder folder, could not delete ", + scalar @messages_part, ' messages: ', $error_imap, "\n" ) ; + errors_incr( $mysync, $error ) ; + } + } + } + + if ( $expunge ) { + uidexpunge_or_expunge( $mysync, $imap, @messages ) ; + } + + #$imap->Debug( 0 ) ; + + return ; +} + + +sub tests_uidexpunge_or_expunge +{ + note( 'Entering tests_uidexpunge_or_expunge()' ) ; + + + is( undef, uidexpunge_or_expunge( ), 'uidexpunge_or_expunge: no args => undef' ) ; + my $mysync ; + is( undef, uidexpunge_or_expunge( $mysync ), 'uidexpunge_or_expunge: undef args => undef' ) ; + $mysync = {} ; + is( undef, uidexpunge_or_expunge( $mysync ), 'uidexpunge_or_expunge: arg empty => undef' ) ; + my $imap ; + is( undef, uidexpunge_or_expunge( $mysync, $imap ), 'uidexpunge_or_expunge: undef Mail-IMAPClient instance => undef' ) ; + + require_ok( "Test::MockObject" ) ; + $imap = Test::MockObject->new( ) ; + is( undef, uidexpunge_or_expunge( $mysync, $imap ), 'uidexpunge_or_expunge: no message (1) to uidexpunge => undef' ) ; + + my @messages = ( ) ; + is( undef, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: no message (2) to uidexpunge => undef' ) ; + + @messages = ( '2', '1' ) ; + $imap->mock( 'uidexpunge', sub { return ; } ) ; + $imap->mock( 'expunge', sub { return ; } ) ; + is( undef, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: uidexpunge failure => expunge failure => undef' ) ; + + $imap->mock( 'expunge', sub { return 1 ; } ) ; + is( 1, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: uidexpunge failure => expunge ok => 1' ) ; + + $imap->mock( 'uidexpunge', sub { return 1 ; } ) ; + is( 1, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: messages to uidexpunge ok => 1' ) ; + + note( 'Leaving tests_uidexpunge_or_expunge()' ) ; + return ; +} + +sub uidexpunge_or_expunge +{ + my $mysync = shift @ARG ; + my $imap = shift @ARG ; + my @messages = @ARG ; + + if ( ! $imap ) { return ; } ; + if ( ! @messages ) { return ; } ; + + # Doing uidexpunge + my @uidexpunge_result = $imap->uidexpunge( @messages ) ; + if ( @uidexpunge_result ) { + return 1 ; + } + # Failure so doing expunge + my $expunge_result = $imap->expunge( ) ; + if ( $expunge_result ) { + return 1 ; + } + # bad trip + return ; +} + +sub eta_print +{ + my $mysync = shift @ARG ; + if ( my $eta = eta( $mysync ) ) + { + myprint( "$eta\n" ) ; + } + return ; +} + +sub tests_eta +{ + note( 'Entering tests_eta()' ) ; + + is( q{}, eta( ), 'eta: no args => ""' ) ; + is( q{}, eta( undef ), 'eta: undef => ""' ) ; + my $mysync = {} ; + # No foldersizes + is( q{}, eta( $mysync ), 'eta: No foldersizes => ""' ) ; + + $mysync->{ foldersizes } = 1 ; + + $mysync->{ begin_transfer_time } = time ; # Now + $mysync->{ h1_nb_msg_processed } = 0 ; + + is( "ETA: " . localtimez( time ) . " 0 s 0/0 msgs left", + eta( $mysync ), + 'eta: no args => ETA: "Now" 0 s 0/0 msgs left' ) ; + + $mysync->{ h1_nb_msg_processed } = 1 ; + $mysync->{ h1_nb_msg_start } = 2 ; + is( "ETA: " . localtimez( time ) . " 0 s 1/2 msgs left", + eta( $mysync ), + 'eta: 1, 1, 2 => ETA: "Now" 0 s 1/2 msgs left' ) ; + + note( 'Leaving tests_eta()' ) ; + return ; +} + + +sub eta +{ + my( $mysync ) = shift @ARG ; + + if ( ! $mysync ) + { + return q{} ; + } + + return( q{} ) if not $mysync->{ foldersizes } ; + + my $h1_nb_msg_start = $mysync->{ h1_nb_msg_start } ; + my $h1_nb_processed = $mysync->{ h1_nb_msg_processed } ; + my $nb_msg_transferred = ( $mysync->{dry} ) ? $mysync->{ h1_nb_msg_processed } : $mysync->{ nb_msg_transferred } ; + my $time_spent = timesince( $mysync->{ begin_transfer_time } ) ; + $h1_nb_processed ||= 0 ; + $h1_nb_msg_start ||= 0 ; + $time_spent ||= 0 ; + + my $time_remaining = time_remaining( $time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_msg_transferred ) ; + $mysync->{ debug } and myprint( "time_spent: $time_spent time_remaining: $time_remaining\n" ) ; + my $nb_msg_remaining = $h1_nb_msg_start - $h1_nb_processed ; + my $eta_date = localtimez( time + $time_remaining ) ; + return( mysprintf( 'ETA: %s %1.0f s %s/%s msgs left', + $eta_date, $time_remaining, $nb_msg_remaining, $h1_nb_msg_start ) ) ; +} + + + + +sub time_remaining +{ + + my( $my_time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_transferred ) = @_ ; + + $nb_transferred ||= 1 ; # At least one is done (no division by zero) + $h1_nb_processed ||= 0 ; + $h1_nb_msg_start ||= $h1_nb_processed ; + $my_time_spent ||= 0 ; + + my $time_remaining = ( $my_time_spent / $nb_transferred ) * ( $h1_nb_msg_start - $h1_nb_processed ) ; + return( $time_remaining ) ; +} + + +sub tests_time_remaining +{ + note( 'Entering tests_time_remaining()' ) ; + + # time_spent, nb_processed, nb_to_do_total, nb_transferred + is( 0, time_remaining( ), 'time_remaining: no args -> 0' ) ; + is( 0, time_remaining( 0, 0, 0, 0 ), 'time_remaining: 0, 0, 0, 0 -> 0' ) ; + is( 1, time_remaining( 1, 1, 2, 1 ), 'time_remaining: 1, 1, 2, 1 -> 1' ) ; + is( 1, time_remaining( 9, 9, 10, 9 ), 'time_remaining: 9, 9, 10, 9 -> 1' ) ; + is( 9, time_remaining( 1, 1, 10, 1 ), 'time_remaining: 1, 1, 10, 1 -> 9' ) ; + is( 5, time_remaining( 5, 5, 10, 5 ), 'time_remaining: 5, 5, 10, 5 -> 5' ) ; + is( 25, time_remaining( 5, 5, 10, 0 ), 'time_remaining: 5, 5, 10, 0 -> ( 5 / 1 ) * ( 10 - 5) = 25' ) ; + is( 25, time_remaining( 5, 5, 10, 1 ), 'time_remaining: 5, 5, 10, 1 -> ( 5 / 1 ) * ( 10 - 5) = 25' ) ; + + note( 'Leaving tests_time_remaining()' ) ; + return ; +} + + + + +sub tests_usecache_and_skipcrossduplicates +{ + note( 'Entering tests_usecache_and_skipcrossduplicates()' ) ; + + is( undef, usecache_and_skipcrossduplicates( ), 'usecache_and_skipcrossduplicates: no args => undef' ) ; + my $mysync = { } ; + is( undef, usecache_and_skipcrossduplicates( $mysync ), 'usecache_and_skipcrossduplicates: undef => undef' ) ; + + $mysync->{ usecache } = $mysync->{ skipcrossduplicates } = 1 ; + is( 1, usecache_and_skipcrossduplicates( $mysync ), 'usecache_and_skipcrossduplicates: usecache=skipcrossduplicates=1 => wrong' ) ; + + note( 'Leaving tests_usecache_and_skipcrossduplicates()' ) ; + return ; +} + +sub usecache_and_skipcrossduplicates +{ + my $mysync = shift @ARG ; + + if ( ! defined $mysync ) { return ; } + + if ( ( $mysync->{ usecache } ) and ( $mysync->{ skipcrossduplicates } ) ) + { + return 1 ; + } + + return ; +} + + + + +sub cache_map +{ + my ( $cache_files_ref, $h1_msgs_ref, $h2_msgs_ref ) = @_; + my ( %map1_2, %map2_1, %done2 ) ; + + my $h1_msgs_hash_ref = { } ; + my $h2_msgs_hash_ref = { } ; + + @{ $h1_msgs_hash_ref }{ @{ $h1_msgs_ref } } = ( ) ; + @{ $h2_msgs_hash_ref }{ @{ $h2_msgs_ref } } = ( ) ; + + foreach my $file ( sort @{ $cache_files_ref } ) { + $debugcache and myprint( "C12: $file\n" ) ; + ( $uid1, $uid2 ) = match_a_cache_file( $file ) ; + + if ( exists( $h1_msgs_hash_ref->{ defined $uid1 ? $uid1 : q{} } ) + and exists( $h2_msgs_hash_ref->{ defined $uid2 ? $uid2 : q{} } ) ) { + # keep only the greatest uid2 + # 130_2301 and + # 130_231 => keep only 130 -> 2301 + + # keep only the greatest uid1 + # 1601_260 and + # 161_260 => keep only 1601 -> 260 + my $max_uid2 = max( $uid2, $map1_2{ $uid1 } || $MINUS_ONE ) ; + if ( exists $done2{ $max_uid2 } ) { + if ( $done2{ $max_uid2 } < $uid1 ) { + $map1_2{ $uid1 } = $max_uid2 ; + delete $map1_2{ $done2{ $max_uid2 } } ; + $done2{ $max_uid2 } = $uid1 ; + } + }else{ + $map1_2{ $uid1 } = $max_uid2 ; + $done2{ $max_uid2 } = $uid1 ; + } + }; + + } + %map2_1 = reverse %map1_2 ; + return( \%map1_2, \%map2_1) ; +} + +sub tests_cache_map +{ + note( 'Entering tests_cache_map()' ) ; + + #$debugcache = 1 ; + my @cache_files = qw ( + 100_200 + 101_201 + 120_220 + 142_242 + 143_243 + 177_277 + 177_278 + 177_279 + 155_255 + 180_280 + 181_280 + 182_280 + 130_231 + 130_2301 + 161_260 + 1601_260 + ) ; + + my $msgs_1 = [120, 142, 143, 144, 161, 1601, 177, 182, 130 ]; + my $msgs_2 = [ 242, 243, 260, 299, 377, 279, 255, 280, 231, 2301 ]; + + my( $c12, $c21 ) ; + ok( ( $c12, $c21 ) = cache_map( \@cache_files, $msgs_1, $msgs_2 ), 'cache_map: 02' ); + my $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ; + my $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ; + ok( 0 == compare_lists( [ 130, 142, 143, 177, 182, 1601 ], $a1 ), 'cache_map: 03' ); + ok( 0 == compare_lists( [ 242, 243, 260, 279, 280, 2301 ], $a2 ), 'cache_map: 04' ); + ok( ! $c12->{161}, 'cache_map: ! 161 -> 260' ); + ok( 260 == $c12->{1601}, 'cache_map: 1601 -> 260' ); + ok( 2301 == $c12->{130}, 'cache_map: 130 -> 2301' ); + #myprint( $c12->{1601}, "\n" ) ; + + note( 'Leaving tests_cache_map()' ) ; + return ; + +} + +sub cache_dir_fix +{ + my $cache_dir = shift @ARG ; + $cache_dir =~ s/([;<>\*\|`&\$!#\(\)\[\]\{\}:'"\\])/\\$1/xg ; + #myprint( "cache_dir_fix: $cache_dir\n" ) ; + return( $cache_dir ) ; +} + +sub tests_cache_dir_fix +{ + note( 'Entering tests_cache_dir_fix()' ) ; + + ok( 'lalala' eq cache_dir_fix('lalala'), 'cache_dir_fix: lalala -> lalala' ); + ok( 'ii\\\\ii' eq cache_dir_fix('ii\ii'), 'cache_dir_fix: ii\ii -> ii\\\\ii' ); + ok( 'ii@ii' eq cache_dir_fix('ii@ii'), 'cache_dir_fix: ii@ii -> ii@ii' ); + ok( 'ii@ii\\:ii' eq cache_dir_fix('ii@ii:ii'), 'cache_dir_fix: ii@ii:ii -> ii@ii\\:ii' ); + ok( 'i\\\\i\\\\ii' eq cache_dir_fix('i\i\ii'), 'cache_dir_fix: i\i\ii -> i\\\\i\\\\ii' ); + ok( 'i\\\\ii' eq cache_dir_fix('i\\ii'), 'cache_dir_fix: i\\ii -> i\\\\\\\\ii' ); + ok( '\\\\ ' eq cache_dir_fix('\\ '), 'cache_dir_fix: \\ -> \\\\\ ' ); + ok( '\\\\ ' eq cache_dir_fix('\ '), 'cache_dir_fix: \ -> \\\\\ ' ); + ok( '\[bracket\]' eq cache_dir_fix('[bracket]'), 'cache_dir_fix: [bracket] -> \[bracket\]' ); + + note( 'Leaving tests_cache_dir_fix()' ) ; + return ; +} + +sub cache_dir_fix_win +{ + my $cache_dir = shift @ARG ; + $cache_dir =~ s/(\[|\])/[$1]/xg ; + #myprint( "cache_dir_fix_win: $cache_dir\n" ) ; + return( $cache_dir ) ; +} + +sub tests_cache_dir_fix_win +{ + note( 'Entering tests_cache_dir_fix_win()' ) ; + + ok( 'lalala' eq cache_dir_fix_win('lalala'), 'cache_dir_fix_win: lalala -> lalala' ); + ok( '[[]bracket[]]' eq cache_dir_fix_win('[bracket]'), 'cache_dir_fix_win: [bracket] -> [[]bracket[]]' ); + + note( 'Leaving tests_cache_dir_fix_win()' ) ; + return ; +} + + + + +sub get_cache +{ + my ( $cache_dir, $h1_msgs_ref, $h2_msgs_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_; + + $debugcache and myprint( "Entering get_cache\n" ) ; + + -d $cache_dir or return( undef ); # exit if cache directory doesn't exist + $debugcache and myprint( "cache_dir : $cache_dir\n" ) ; + + + if ( 'MSWin32' ne $OSNAME ) { + $cache_dir = cache_dir_fix( $cache_dir ) ; + }else{ + $cache_dir = cache_dir_fix_win( $cache_dir ) ; + } + + $debugcache and myprint( "cache_dir_fix: $cache_dir\n" ) ; + + my @cache_files = bsd_glob( "$cache_dir/*" ) ; + #$debugcache and myprint( "cache_files: [@cache_files]\n" ) ; + + $debugcache and myprint( 'cache_files: ', scalar @cache_files , " files found\n" ) ; + + my( $cache_1_2_ref, $cache_2_1_ref ) + = cache_map( \@cache_files, $h1_msgs_ref, $h2_msgs_ref ) ; + + clean_cache( \@cache_files, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ; + + $debugcache and myprint( "Exiting get_cache\n" ) ; + return( $cache_1_2_ref, $cache_2_1_ref ) ; +} + + +sub tests_get_cache +{ + note( 'Entering tests_get_cache()' ) ; + + ok( not( get_cache('/cache_no_exist') ), 'get_cache: /cache_no_exist' ); + ok( ( not -d 'W/tmp/cache/F1/F2' or rmtree( 'W/tmp/cache/F1/F2' ) ), 'get_cache: rmtree W/tmp/cache/F1/F2' ) ; + ok( mkpath( 'W/tmp/cache/F1/F2' ), 'get_cache: mkpath W/tmp/cache/F1/F2' ) ; + + my @test_files_cache = ( qw( + W/tmp/cache/F1/F2/100_200 + W/tmp/cache/F1/F2/101_201 + W/tmp/cache/F1/F2/120_220 + W/tmp/cache/F1/F2/142_242 + W/tmp/cache/F1/F2/143_243 + W/tmp/cache/F1/F2/177_277 + W/tmp/cache/F1/F2/177_377 + W/tmp/cache/F1/F2/177_777 + W/tmp/cache/F1/F2/155_255 + ) ) ; + ok( touch( @test_files_cache ), 'get_cache: touch W/tmp/cache/F1/F2/...' ) ; + + + # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255 + # on live: + my $msgs_1 = [120, 142, 143, 144, 177 ]; + my $msgs_2 = [ 242, 243, 299, 377, 777, 255 ]; + + my $msgs_all_1 = { 120 => 0, 142 => 0, 143 => 0, 144 => 0, 177 => 0 } ; + my $msgs_all_2 = { 242 => 0, 243 => 0, 299 => 0, 377 => 0, 777 => 0, 255 => 0 } ; + + my( $c12, $c21 ) ; + ok( ( $c12, $c21 ) = get_cache( 'W/tmp/cache/F1/F2', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2 ), 'get_cache: 02' ); + my $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ; + my $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ; + ok( 0 == compare_lists( [ 142, 143, 177 ], $a1 ), 'get_cache: 03' ); + ok( 0 == compare_lists( [ 242, 243, 777 ], $a2 ), 'get_cache: 04' ); + ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 142_242'); + ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 143_243'); + ok( ! -f 'W/tmp/cache/F1/F2/100_200', 'get_cache: file removed 100_200'); + ok( ! -f 'W/tmp/cache/F1/F2/101_201', 'get_cache: file removed 101_201'); + + # test clean_cache executed + $maxage = 2 ; + ok( touch(@test_files_cache), 'get_cache: touch W/tmp/cache/F1/F2/...' ) ; + ok( ( $c12, $c21 ) = get_cache('W/tmp/cache/F1/F2', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2 ), 'get_cache: 02' ); + ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 142_242'); + ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 143_243'); + ok( ! -f 'W/tmp/cache/F1/F2/100_200', 'get_cache: file NOT removed 100_200'); + ok( ! -f 'W/tmp/cache/F1/F2/101_201', 'get_cache: file NOT removed 101_201'); + + + # strange files + #$debugcache = 1 ; + $maxage = undef ; + ok( ( not -d 'W/tmp/cache/rr\uee' or rmtree( 'W/tmp/cache/rr\uee' )), 'get_cache: rmtree W/tmp/cache/rr\uee' ) ; + ok( mkpath( 'W/tmp/cache/rr\uee' ), 'get_cache: mkpath W/tmp/cache/rr\uee' ) ; + + @test_files_cache = ( qw( + W/tmp/cache/rr\uee/100_200 + W/tmp/cache/rr\uee/101_201 + W/tmp/cache/rr\uee/120_220 + W/tmp/cache/rr\uee/142_242 + W/tmp/cache/rr\uee/143_243 + W/tmp/cache/rr\uee/177_277 + W/tmp/cache/rr\uee/177_377 + W/tmp/cache/rr\uee/177_777 + W/tmp/cache/rr\uee/155_255 + ) ) ; + ok( touch(@test_files_cache), 'get_cache: touch strange W/tmp/cache/...' ) ; + + # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255 + # on live: + $msgs_1 = [120, 142, 143, 144, 177 ] ; + $msgs_2 = [ 242, 243, 299, 377, 777, 255 ] ; + + $msgs_all_1 = { 120 => q{}, 142 => q{}, 143 => q{}, 144 => q{}, 177 => q{} } ; + $msgs_all_2 = { 242 => q{}, 243 => q{}, 299 => q{}, 377 => q{}, 777 => q{}, 255 => q{} } ; + + ok( ( $c12, $c21 ) = get_cache('W/tmp/cache/rr\uee', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2), 'get_cache: strange path 02' ); + $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ; + $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ; + ok( 0 == compare_lists( [ 142, 143, 177 ], $a1 ), 'get_cache: strange path 03' ); + ok( 0 == compare_lists( [ 242, 243, 777 ], $a2 ), 'get_cache: strange path 04' ); + ok( -f 'W/tmp/cache/rr\uee/142_242', 'get_cache: strange path file kept 142_242'); + ok( -f 'W/tmp/cache/rr\uee/142_242', 'get_cache: strange path file kept 143_243'); + ok( ! -f 'W/tmp/cache/rr\uee/100_200', 'get_cache: strange path file removed 100_200'); + ok( ! -f 'W/tmp/cache/rr\uee/101_201', 'get_cache: strange path file removed 101_201'); + + note( 'Leaving tests_get_cache()' ) ; + return ; +} + +sub match_a_cache_file +{ + my $file = shift @ARG ; + my ( $cache_uid1, $cache_uid2 ) ; + + return( ( undef, undef ) ) if ( ! $file ) ; + if ( $file =~ m{(?:^|/)(\d+)_(\d+)$}x ) { + $cache_uid1 = $1 ; + $cache_uid2 = $2 ; + } + return( $cache_uid1, $cache_uid2 ) ; +} + +sub tests_match_a_cache_file +{ + note( 'Entering tests_match_a_cache_file()' ) ; + + my ( $tuid1, $tuid2 ) ; + ok( ( $tuid1, $tuid2 ) = match_a_cache_file( ), 'match_a_cache_file: no arg' ) ; + ok( ! defined $tuid1 , 'match_a_cache_file: no arg 1' ) ; + ok( ! defined $tuid2 , 'match_a_cache_file: no arg 2' ) ; + + ok( ( $tuid1, $tuid2 ) = match_a_cache_file( q{} ), 'match_a_cache_file: empty arg' ) ; + ok( ! defined $tuid1 , 'match_a_cache_file: empty arg 1' ) ; + ok( ! defined $tuid2 , 'match_a_cache_file: empty arg 2' ) ; + + ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '000_000' ), 'match_a_cache_file: 000_000' ) ; + ok( '000' eq $tuid1, 'match_a_cache_file: 000_000 1' ) ; + ok( '000' eq $tuid2, 'match_a_cache_file: 000_000 2' ) ; + + ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '123_456' ), 'match_a_cache_file: 123_456' ) ; + ok( '123' eq $tuid1, 'match_a_cache_file: 123_456 1' ) ; + ok( '456' eq $tuid2, 'match_a_cache_file: 123_456 2' ) ; + + ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/tmp/truc/123_456' ), 'match_a_cache_file: /tmp/truc/123_456' ) ; + ok( '123' eq $tuid1, 'match_a_cache_file: /tmp/truc/123_456 1' ) ; + ok( '456' eq $tuid2, 'match_a_cache_file: /tmp/truc/123_456 2' ) ; + + ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/lala123_456' ), 'match_a_cache_file: NO /lala123_456' ) ; + ok( ! $tuid1, 'match_a_cache_file: /lala123_456 1' ) ; + ok( ! $tuid2, 'match_a_cache_file: /lala123_456 2' ) ; + + ok( ( $tuid1, $tuid2 ) = match_a_cache_file( 'la123_456' ), 'match_a_cache_file: NO la123_456' ) ; + ok( ! $tuid1, 'match_a_cache_file: la123_456 1' ) ; + ok( ! $tuid2, 'match_a_cache_file: la123_456 2' ) ; + + note( 'Leaving tests_match_a_cache_file()' ) ; + return ; +} + +sub clean_cache +{ + my ( $cache_files_ref, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_ ; + + $debugcache and myprint( "Entering clean_cache\n" ) ; + + $debugcache and myprint( map { "$_ -> " . $cache_1_2_ref->{ $_ } . "\n" } keys %{ $cache_1_2_ref } ) ; + foreach my $file ( @{ $cache_files_ref } ) { + $debugcache and myprint( "$file\n" ) ; + my ( $cache_uid1, $cache_uid2 ) = match_a_cache_file( $file ) ; + $debugcache and myprint( "u1: $cache_uid1 u2: $cache_uid2 c12: ", $cache_1_2_ref->{ $cache_uid1 } || q{}, "\n") ; +# or ( ! exists( $cache_1_2_ref->{ $cache_uid1 } ) ) +# or ( ! ( $cache_uid2 == $cache_1_2_ref->{ $cache_uid1 } ) ) + if ( ( not defined $cache_uid1 ) + or ( not defined $cache_uid2 ) + or ( not exists $h1_msgs_all_hash_ref->{ $cache_uid1 } ) + or ( not exists $h2_msgs_all_hash_ref->{ $cache_uid2 } ) + ) { + $debugcache and myprint( "remove $file\n" ) ; + unlink $file or myprint( "$OS_ERROR" ) ; + } + } + + $debugcache and myprint( "Exiting clean_cache\n" ) ; + return( 1 ) ; +} + +sub tests_clean_cache +{ + note( 'Entering tests_clean_cache()' ) ; + + ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'clean_cache: rmtree W/tmp/cache/G1/G2' ) ; + ok( mkpath( 'W/tmp/cache/G1/G2' ), 'clean_cache: mkpath W/tmp/cache/G1/G2' ) ; + + my @test_files_cache = ( qw( + W/tmp/cache/G1/G2/100_200 + W/tmp/cache/G1/G2/101_201 + W/tmp/cache/G1/G2/120_220 + W/tmp/cache/G1/G2/142_242 + W/tmp/cache/G1/G2/143_243 + W/tmp/cache/G1/G2/177_277 + W/tmp/cache/G1/G2/177_377 + W/tmp/cache/G1/G2/177_777 + W/tmp/cache/G1/G2/155_255 + ) ) ; + ok( touch(@test_files_cache), 'clean_cache: touch W/tmp/cache/G1/G2/...' ) ; + + ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 before' ); + ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 before' ); + ok( -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 before' ); + ok( -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 before' ); + ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 before' ); + ok( -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 before' ); + + my $cache = { + 142 => 242, + 177 => 777, + } ; + + my $all_1 = { + 142 => q{}, + 177 => q{}, + } ; + + my $all_2 = { + 200 => q{}, + 242 => q{}, + 777 => q{}, + } ; + ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), 'clean_cache: ' ) ; + + ok( ! -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 after' ); + ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 after' ); + ok( ! -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 after' ); + ok( ! -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 after' ); + ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 after' ); + ok( ! -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 after' ); + + note( 'Leaving tests_clean_cache()' ) ; + return ; +} + +sub tests_clean_cache_2 +{ + note( 'Entering tests_clean_cache_2()' ) ; + + ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'clean_cache_2: rmtree W/tmp/cache/G1/G2' ) ; + ok( mkpath( 'W/tmp/cache/G1/G2' ), 'clean_cache_2: mkpath W/tmp/cache/G1/G2' ) ; + + my @test_files_cache = ( qw( + W/tmp/cache/G1/G2/100_200 + W/tmp/cache/G1/G2/101_201 + W/tmp/cache/G1/G2/120_220 + W/tmp/cache/G1/G2/142_242 + W/tmp/cache/G1/G2/143_243 + W/tmp/cache/G1/G2/177_277 + W/tmp/cache/G1/G2/177_377 + W/tmp/cache/G1/G2/177_777 + W/tmp/cache/G1/G2/155_255 + ) ) ; + ok( touch(@test_files_cache), 'clean_cache_2: touch W/tmp/cache/G1/G2/...' ) ; + + ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 before' ); + ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 before' ); + ok( -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 before' ); + ok( -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 before' ); + ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 before' ); + ok( -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache_2: 155_255 before' ); + + my $cache = { + 142 => 242, + 177 => 777, + } ; + + my $all_1 = { + $NUMBER_100 => q{}, + 142 => q{}, + 177 => q{}, + } ; + + my $all_2 = { + 200 => q{}, + 242 => q{}, + 777 => q{}, + } ; + + + + ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), 'clean_cache_2: ' ) ; + + ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 after' ); + ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 after' ); + ok( ! -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 after' ); + ok( ! -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 after' ); + ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 after' ); + ok( ! -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache_2: 155_255 after' ); + + note( 'Leaving tests_clean_cache_2()' ) ; + return ; +} + + + +sub tests_mkpath +{ + note( 'Entering tests_mkpath()' ) ; + + ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' )), 'mkpath: mkpath W/tmp/tests/' ) ; + + SKIP: { + skip( 'Tests only for Unix', 10 ) if ( 'MSWin32' eq $OSNAME ) ; + my $long_path_unix = '123456789/' x 30 ; + ok( ( -d "W/tmp/tests/long/$long_path_unix" or mkpath( "W/tmp/tests/long/$long_path_unix" ) ), 'mkpath: mkpath 300 char' ) ; + ok( -d "W/tmp/tests/long/$long_path_unix", 'mkpath: mkpath > 300 char verified' ) ; + ok( ( -d "W/tmp/tests/long/$long_path_unix" and rmtree( 'W/tmp/tests/long/' ) ), 'mkpath: rmtree 300 char' ) ; + ok( ! -d "W/tmp/tests/long/$long_path_unix", 'mkpath: rmtree 300 char verified' ) ; + + ok( ( -d 'W/tmp/tests/trailing_dots...' or mkpath( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: mkpath trailing_dots...' ) ; + ok( -d 'W/tmp/tests/trailing_dots...', 'mkpath: mkpath trailing_dots... verified' ) ; + ok( ( -d 'W/tmp/tests/trailing_dots...' and rmtree( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: rmtree trailing_dots...' ) ; + ok( ! -d 'W/tmp/tests/trailing_dots...', 'mkpath: rmtree trailing_dots... verified' ) ; + + eval { ok( 1 / 0, 'mkpath: divide by 0' ) ; } or ok( 1, 'mkpath: can not divide by 0' ) ; + ok( 1, 'mkpath: still alive' ) ; + } ; + + SKIP: { + skip( 'Tests only for MSWin32', 13 ) if ( 'MSWin32' ne $OSNAME ) ; + my $long_path_2_prefix = ".\\imapsync_tests" || '\\\?\\E:\\TEMP\\imapsync_tests' ; + myprint( "long_path_2_prefix: $long_path_2_prefix\n" ) ; + + my $long_path_100 = $long_path_2_prefix . '\\' . '123456789\\' x 10 . 'END' ; + my $long_path_300 = $long_path_2_prefix . '\\' . '123456789\\' x 30 . 'END' ; + + #myprint( "$long_path_100\n" ) ; + + ok( ( -d $long_path_2_prefix or mkpath( $long_path_2_prefix ) ), 'mkpath: -d mkpath small path' ) ; + ok( ( -d $long_path_2_prefix ), 'mkpath: -d mkpath small path done' ) ; + ok( ( -d $long_path_100 or mkpath( $long_path_100 ) ), 'mkpath: mkpath > 100 char' ) ; + ok( ( -d $long_path_100 ), 'mkpath: -d mkpath > 200 char done' ) ; + ok( ( -d $long_path_2_prefix and rmtree( $long_path_2_prefix ) ), 'mkpath: rmtree > 100 char' ) ; + ok( (! -d $long_path_2_prefix ), 'mkpath: ! -d rmtree done' ) ; + + # Without the eval the following mkpath 300 just kill the whole process without a whisper + #myprint( "$long_path_300\n" ) ; + eval { ok( ( -d $long_path_300 or mkpath( $long_path_300 ) ), 'mkpath: create a path with 300 characters' ) ; } + or ok( 1, 'mkpath: can not create a path with 300 characters' ) ; + ok( ( ( ! -d $long_path_300 ) or -d $long_path_300 and rmtree( $long_path_300 ) ), 'mkpath: rmtree the 300 character path' ) ; + ok( 1, 'mkpath: still alive' ) ; + + ok( ( -d 'W/tmp/tests/trailing_dots...' or mkpath( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: mkpath trailing_dots...' ) ; + ok( -d 'W/tmp/tests/trailing_dots...', 'mkpath: mkpath trailing_dots... verified' ) ; + ok( ( -d 'W/tmp/tests/trailing_dots...' and rmtree( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: rmtree trailing_dots...' ) ; + ok( ! -d 'W/tmp/tests/trailing_dots...', 'mkpath: rmtree trailing_dots... verified' ) ; + + + } ; + + note( 'Leaving tests_mkpath()' ) ; + # Keep this because of the eval used by the caller (failed badly?) + return 1 ; +} + +sub tests_touch +{ + note( 'Entering tests_touch()' ) ; + + ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' )), 'touch: mkpath W/tmp/tests/' ) ; + ok( 1 == touch( 'W/tmp/tests/lala'), 'touch: W/tmp/tests/lala') ; + ok( 1 == touch( 'W/tmp/tests/\y'), 'touch: W/tmp/tests/\y') ; + ok( 0 == touch( '/no/no/no/aaa'), 'touch: not /aaa') ; + ok( 1 == touch( 'W/tmp/tests/lili', 'W/tmp/tests/lolo'), 'touch: 2 files') ; + ok( 0 == touch( 'W/tmp/tests/\y', '/no/no/aaa'), 'touch: 2 files, 1 fails' ) ; + + note( 'Leaving tests_touch()' ) ; + return ; +} + + +sub touch +{ + my @files = @_ ; + my $failures = 0 ; + + foreach my $file ( @files ) { + my $fh = IO::File->new ; + if ( $fh->open(">> $file" ) ) { + $fh->close ; + }else{ + myprint( "Could not open file $file in write/append mode\n" ) ; + $failures++ ; + } + } + return( ! $failures ); +} + + + +sub tests_tmpdir_has_colon_bug +{ + note( 'Entering tests_tmpdir_has_colon_bug()' ) ; + + ok( 0 == tmpdir_has_colon_bug( q{} ), 'tmpdir_has_colon_bug: ' ) ; + ok( 0 == tmpdir_has_colon_bug( '/tmp' ), 'tmpdir_has_colon_bug: /tmp' ) ; + ok( 1 == tmpdir_has_colon_bug( 'C:' ), 'tmpdir_has_colon_bug: C:' ) ; + ok( 1 == tmpdir_has_colon_bug( 'C:\temp' ), 'tmpdir_has_colon_bug: C:\temp' ) ; + + note( 'Leaving tests_tmpdir_has_colon_bug()' ) ; + return ; +} + +sub tmpdir_has_colon_bug +{ + my $path = shift @ARG ; + + my $path_filtered = filter_forbidden_characters( $path ) ; + if ( $path_filtered ne $path ) { + ( -d $path_filtered ) and myprint( "Path $path was previously mistakely changed to $path_filtered\n" ) ; + return( 1 ) ; + } + return( 0 ) ; +} + +sub tmpdir_fix_colon_bug +{ + my $mysync = shift @ARG ; + my $err = 0 ; + if ( not (-d $mysync->{ tmpdir } and -r _ and -w _) ) { + myprint( "tmpdir $mysync->{ tmpdir } is not valid\n" ) ; + return( 0 ) ; + } + my $cachedir_new = "$mysync->{ tmpdir }/imapsync_cache" ; + + if ( not tmpdir_has_colon_bug( $cachedir_new ) ) { return( 0 ) } ; + + # check if old cache directory already exists + my $cachedir_old = filter_forbidden_characters( $cachedir_new ) ; + if ( not ( -d $cachedir_old ) ) { + myprint( "Old cache directory $cachedir_new no exists, nothing to do\n" ) ; + return( 1 ) ; + } + # check if new cache directory already exists + if ( -d $cachedir_new ) { + myprint( "New fixed cache directory $cachedir_new already exists, not moving the old one $cachedir_old. Fix this manually.\n" ) ; + return( 0 ) ; + }else{ + # move the old one to the new place + myprint( "Moving $cachedir_old to $cachedir_new Do not interrupt this task.\n" ) ; + File::Copy::Recursive::rmove( $cachedir_old, $cachedir_new ) + or do { + myprint( "Could not move $cachedir_old to $cachedir_new\n" ) ; + $err++ ; + } ; + # check it succeeded + if ( -d $cachedir_new and -r _ and -w _ ) { + myprint( "New fixed cache directory $cachedir_new ok\n" ) ; + }else{ + myprint( "New fixed cache directory $cachedir_new does not exist\n" ) ; + $err++ ; + } + if ( -d $cachedir_old ) { + myprint( "Old cache directory $cachedir_old still exists\n" ) ; + $err++ ; + }else{ + myprint( "Old cache directory $cachedir_old successfully moved\n" ) ; + } + } + return( not $err ) ; +} + + +sub tests_cache_folder +{ + note( 'Entering tests_cache_folder()' ) ; + + ok( '/path/fold1/fold2' eq cache_folder( q{}, '/path', 'fold1', 'fold2'), 'cache_folder: /path, fold1, fold2 -> /path/fold1/fold2' ) ; + ok( '/pa_th/fold1/fold2' eq cache_folder( q{}, '/pa*th', 'fold1', 'fold2'), 'cache_folder: /pa*th, fold1, fold2 -> /path/fold1/fold2' ) ; + ok( '/_p_a__th/fol_d1/fold2' eq cache_folder( q{}, '/>pp /path/fol_d1/fold2' ) ; + + ok( 'D:/path/fold1/fold2' eq cache_folder( 'D:', '/path', 'fold1', 'fold2'), 'cache_folder: /path, fold1, fold2 -> /path/fold1/fold2' ) ; + ok( 'D:/pa_th/fold1/fold2' eq cache_folder( 'D:', '/pa*th', 'fold1', 'fold2'), 'cache_folder: /pa*th, fold1, fold2 -> /path/fold1/fold2' ) ; + ok( 'D:/_p_a__th/fol_d1/fold2' eq cache_folder( 'D:', '/>pp /path/fol_d1/fold2' ) ; + ok( '//' eq cache_folder( q{}, q{}, q{}, q{}), 'cache_folder: -> //' ) ; + ok( '//_______' eq cache_folder( q{}, q{}, q{}, '*|?:"<>'), 'cache_folder: *|?:"<> -> //_______' ) ; + + note( 'Leaving tests_cache_folder()' ) ; + return ; +} + +sub cache_folder +{ + my( $cache_base, $cache_dir, $h1_fold, $h2_fold ) = @_ ; + + my $sep_1 = $sync->{ h1_sep } || '/'; + my $sep_2 = $sync->{ h2_sep } || '/'; + + #myprint( "$cache_dir h1_fold $h1_fold sep1 $sep_1 h2_fold $h2_fold sep2 $sep_2\n" ) ; + $h1_fold = convert_sep_to_slash( $h1_fold, $sep_1 ) ; + $h2_fold = convert_sep_to_slash( $h2_fold, $sep_2 ) ; + + my $cache_folder = "$cache_base" . filter_forbidden_characters( "$cache_dir/$h1_fold/$h2_fold" ) ; + #myprint( "cache_folder [$cache_folder]\n" ) ; + return( $cache_folder ) ; +} + +sub tests_filter_forbidden_characters +{ + note( 'Entering tests_filter_forbidden_characters()' ) ; + + is( undef , filter_forbidden_characters( ), 'filter_forbidden_characters: no args -> undef' ) ; + is( '' , filter_forbidden_characters( '' ), 'filter_forbidden_characters: empty string -> empty string' ) ; + + is( 'a_b' , filter_forbidden_characters( 'a_b' ), 'filter_forbidden_characters: a_b -> a_b' ) ; + is( 'a_b' , filter_forbidden_characters( 'a*b' ), 'filter_forbidden_characters: a*b -> a_b' ) ; + is( 'a_b' , filter_forbidden_characters( 'a|b' ), 'filter_forbidden_characters: a|b -> a_b' ) ; + is( 'a_b' , filter_forbidden_characters( 'a?b' ), 'filter_forbidden_characters: a?b -> a_b' ) ; + is( 'a________b', filter_forbidden_characters( q{a*|?:"<>'b} ), q{filter_forbidden_characters: a*|?:"<>'b -> a________b} ) ; + + + is( 'a_b_' , filter_forbidden_characters( 'a b ' ), 'filter_forbidden_characters: "a b " -> "a_b_"' ) ; + + + is( 'a_b' , filter_forbidden_characters( "a\tb" ), 'filter_forbidden_characters: a\tb -> a_b' ) ; + is( "a_b" , filter_forbidden_characters( "a\rb" ), 'filter_forbidden_characters: a\rb -> a_b' ) ; + is( "a_b" , filter_forbidden_characters( "a\nb" ), 'filter_forbidden_characters: a\nb -> a_b' ) ; + is( "a_b" , filter_forbidden_characters( "a\\b" ), 'filter_forbidden_characters: a\b -> a_b' ) ; + + is( 'a-b' , filter_forbidden_characters( 'a-b' ), 'filter_forbidden_characters: a-b -> a-b' ) ; + is( 'a__-__-__-__-__b' , filter_forbidden_characters( 'aé-è-à-ç-Öb' ), 'filter_forbidden_characters: aé-è-à-ç-Öb -> a__-__-__-__-__b' ) ; + + is( 'abcdABCDwxyzWXYZ012789' , filter_forbidden_characters( 'abcdABCDwxyzWXYZ012789' ), + 'filter_forbidden_characters: abcdABCDwxyzWXYZ012789 -> abcdABCDwxyzWXYZ012789' ) ; + + + note( 'Leaving tests_filter_forbidden_characters()' ) ; + return ; +} + +sub filter_forbidden_characters +{ + my $string = shift @ARG ; + + if ( ! defined $string ) { return ; } + + $string =~ s{[\Q*|?:"<>' \E\t\r\n\\]}{_}xg ; + # replace all non-ascii and control characters by _ + $string =~ s/[[:^ascii:][:cntrl:]]/_/xg ; + + #myprint( "[$string]\n" ) ; + return( $string ) ; +} + +sub tests_convert_sep_to_slash +{ + note( 'Entering tests_convert_sep_to_slash()' ) ; + + + ok(q{} eq convert_sep_to_slash(q{}, '/'), 'convert_sep_to_slash: no folder'); + ok('INBOX' eq convert_sep_to_slash('INBOX', '/'), 'convert_sep_to_slash: INBOX'); + ok('INBOX/foo' eq convert_sep_to_slash('INBOX/foo', '/'), 'convert_sep_to_slash: INBOX/foo'); + ok('INBOX/foo' eq convert_sep_to_slash('INBOX_foo', '_'), 'convert_sep_to_slash: INBOX_foo'); + ok('INBOX/foo/zob' eq convert_sep_to_slash('INBOX_foo_zob', '_'), 'convert_sep_to_slash: INBOX_foo_zob'); + ok('INBOX/foo' eq convert_sep_to_slash('INBOX.foo', '.'), 'convert_sep_to_slash: INBOX.foo'); + ok('INBOX/foo/hi' eq convert_sep_to_slash('INBOX.foo.hi', '.'), 'convert_sep_to_slash: INBOX.foo.hi'); + + note( 'Leaving tests_convert_sep_to_slash()' ) ; + return ; +} + +sub convert_sep_to_slash +{ + my ( $folder, $sep ) = @_ ; + + $folder =~ s{\Q$sep\E}{/}xg ; + return( $folder ) ; +} + + +sub tests_regexmess +{ + note( 'Entering tests_regexmess()' ) ; + + ok( 'blabla' eq regexmess( 'blabla' ), 'regexmess: no regexmess, nothing to do' ) ; + + @regexmess = ( 'lalala' ) ; + ok( not( defined regexmess( 'popopo' ) ), 'regexmess: bad regex lalala' ) ; + + @regexmess = ( 's/p/Z/g' ) ; + ok( 'ZoZoZo' eq regexmess( 'popopo' ), 'regexmess: s/p/Z/g' ) ; + + @regexmess = ( 's{c}{C}gxms' ) ; + ok("H1: abC\nH2: Cde\n\nBody abC" + eq regexmess( "H1: abc\nH2: cde\n\nBody abc"), + 'regexmess: c->C'); + + @regexmess = ( 's{\AFrom\ }{From:}gxms' ) ; + ok( q{} + eq regexmess(q{}), + 'regexmess: From mbox 1 add colon blank'); + + ok( 'From:' + eq regexmess('From '), + 'regexmess: From mbox 2 add colo'); + + ok( "\n" . 'From ' + eq regexmess("\n" . 'From '), + 'regexmess: From mbox 3 add colo') ; + + ok( "From: zzz\n" . 'From ' + eq regexmess("From zzz\n" . 'From '), + 'regexmess: From mbox 4 add colo') ; + + @regexmess = ( 's{\AFrom\ [^\n]*(\n)?}{}gxms' ) ; + ok( q{} + eq regexmess(q{}), + 'regexmess: From mbox 1 remove, blank'); + + ok( q{} + eq regexmess('From '), + 'regexmess: From mbox 2 remove'); + + ok( "\n" . 'From ' + eq regexmess("\n" . 'From '), + 'regexmess: From mbox 3 remove'); + + #myprint( "[", regexmess("From zzz\n" . 'From '), "]" ) ; + ok( q{} . 'From ' + eq regexmess("From zzz\n" . 'From '), + 'regexmess: From mbox 4 remove'); + + + is( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye. +EOM + , regexmess( +<<'EOM' +From zzz +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye. +EOM + ), 'regexmess: From mbox 5 remove'); + + +@regexmess = ( 's{\A((?:[^\n]+\n)+|)^Disposition-Notification-To:[^\n]*\n(\r?\n|.*\n\r?\n)}{$1$2}xms' ) ; # SUPER SUPER BEST! + ok( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye. +EOM + eq regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +Disposition-Notification-To: Gilles LAMIRAL +From: + +Hello, +Bye. +EOM + ), + 'regexmess: 1 Delete header Disposition-Notification-To:'); + + ok( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye. +EOM + eq regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: +Disposition-Notification-To: Gilles LAMIRAL + +Hello, +Bye. +EOM + ), + 'regexmess: 2 Delete header Disposition-Notification-To:'); + + ok( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye. +EOM + eq regexmess( +<<'EOM' +Disposition-Notification-To: Gilles LAMIRAL +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye. +EOM + ), + 'regexmess: 3 Delete header Disposition-Notification-To:'); + + ok( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Disposition-Notification-To: Gilles LAMIRAL +Bye. +EOM + eq regexmess( +<<'EOM' +Disposition-Notification-To: Gilles LAMIRAL +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Disposition-Notification-To: Gilles LAMIRAL +Bye. +EOM + ), + 'regexmess: 4 Delete header Disposition-Notification-To:'); + + + ok( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Disposition-Notification-To: Gilles LAMIRAL +Bye. +EOM + eq regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Disposition-Notification-To: Gilles LAMIRAL +Bye. +EOM + ), + 'regexmess: 5 Delete header Disposition-Notification-To:'); + + + ok( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Disposition-Notification-To: Gilles LAMIRAL +Bye. +EOM + eq regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Disposition-Notification-To: Gilles LAMIRAL +Bye. +EOM + ), + 'regexmess: 6 Delete header Disposition-Notification-To:'); + + ok( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Disposition-Notification-To: Gilles LAMIRAL + +Bye. +EOM + eq regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Disposition-Notification-To: Gilles LAMIRAL + +Bye. +EOM + ), + 'regexmess: 7 Delete header Disposition-Notification-To:'); + + + ok( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye. +EOM + eq regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye. +EOM +), + 'regexmess: 8 Delete header Disposition-Notification-To:'); + + + ok( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Disposition-Notification-To: Gilles LAMIRAL +Bye. +EOM + eq regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Disposition-Notification-To: Gilles LAMIRAL +Bye. +EOM + ), + 'regexmess: 9 Delete header Disposition-Notification-To:'); + + + + ok( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Disposition-Notification-To: Gilles LAMIRAL + + +Bye. +EOM + eq regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Disposition-Notification-To: Gilles LAMIRAL + + +Bye. +EOM + ), + 'regexmess: 10 Delete header Disposition-Notification-To:'); + + ok( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, + +Disposition-Notification-To: Gilles LAMIRAL + +Bye. +EOM + eq regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, + +Disposition-Notification-To: Gilles LAMIRAL + +Bye. +EOM +), + 'regexmess: 11 Delete header Disposition-Notification-To:'); + + ok( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, + +Disposition-Notification-To: Gilles LAMIRAL + +Disposition-Notification-To: Gilles LAMIRAL + +Bye. +EOM + eq regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, + +Disposition-Notification-To: Gilles LAMIRAL + +Disposition-Notification-To: Gilles LAMIRAL + +Bye. +EOM + ), + 'regexmess: 12 Delete header Disposition-Notification-To:'); + + + @regexmess = ( 's{\A(.*?(?! ^$))^Disposition-Notification-To:(.*?)$}{$1X-Disposition-Notification-To:$2}igxms' ) ; # BAD! + @regexmess = ( 's{\A((?:[^\n]+\n)+|)(^Disposition-Notification-To:[^\n]*\n)(\r?\n|.*\n\r?\n)}{$1X-$2$3}ims' ) ; + + + ok( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, + +Disposition-Notification-To: Gilles LAMIRAL + +Disposition-Notification-To: Gilles LAMIRAL + +Bye. +EOM + eq regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, + +Disposition-Notification-To: Gilles LAMIRAL + +Disposition-Notification-To: Gilles LAMIRAL + +Bye. +EOM + ), + 'regexmess: 13 Delete header Disposition-Notification-To:'); + + ok( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +X-Disposition-Notification-To: Gilles LAMIRAL +From: + +Hello, + +Disposition-Notification-To: Gilles LAMIRAL + +Disposition-Notification-To: Gilles LAMIRAL + +Bye. +EOM + eq regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +Disposition-Notification-To: Gilles LAMIRAL +From: + +Hello, + +Disposition-Notification-To: Gilles LAMIRAL + +Disposition-Notification-To: Gilles LAMIRAL + +Bye. +EOM + ), + 'regexmess: 14 Delete header Disposition-Notification-To:'); + + ok( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +X-Disposition-Notification-To: Gilles LAMIRAL +From: + +Hello, + +Bye. +EOM + eq regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +Disposition-Notification-To: Gilles LAMIRAL +From: + +Hello, + +Bye. +EOM + ), + 'regexmess: 15 Delete header Disposition-Notification-To:'); + + + ok( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: +X-Disposition-Notification-To: Gilles LAMIRAL + +Hello, + +Bye. +EOM + eq regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: +Disposition-Notification-To: Gilles LAMIRAL + +Hello, + +Bye. +EOM + ), + 'regexmess: 16 Delete header Disposition-Notification-To:'); + + ok( +<<'EOM' +X-Disposition-Notification-To: Gilles LAMIRAL +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, + +Bye. +EOM + eq regexmess( +<<'EOM' +Disposition-Notification-To: Gilles LAMIRAL +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, + +Bye. +EOM +), + 'regexmess: 17 Delete header Disposition-Notification-To:'); + + @regexmess = ( 's/.{11}\K.*//gs' ) ; + is( "0123456789\n", regexmess( "0123456789\n" x 100 ), 'regexmess: truncate whole message after 11 characters' ) ; + is( "0123456789\n", regexmess( "0123456789\n" x 100_000 ), 'regexmess: truncate whole message after 11 characters ~ 1MB' ) ; + + @regexmess = ( 's/.{10000}\K.*//gs' ) ; + is( "123456789\n" x 1000, regexmess( "123456789\n" x 100_000 ), 'regexmess: truncate whole message after 10000 characters ~ 1MB' ) ; + + @regexmess = ( 's/^(X-Ham-Report.*?\n)^X-/X-/sm' ) ; + + is( +<<'EOM' +X-Spam-Score: -1 +X-Spam-Bar: / +X-Spam-Flag: NO +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, + +Bye. +EOM +, + regexmess( +<<'EOM' +X-Spam-Score: -1 +X-Spam-Bar: / +X-Ham-Report: =?utf-8?Q?Spam_detection_software=2C_running?= + =?utf-8?Q?_on_the_system_=22ohp-ag006.int200?= +_has_NOT_identified_thi?= + =?utf-8?Q?s_incoming_email_as_spam.__The_o?= +_message_has_been_attac?= + =?utf-8?Q?hed_to_this_so_you_can_view_it_o?= +___________________________?= + =?utf-8?Q?__author's_domain +X-Spam-Flag: NO +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, + +Bye. +EOM + ), + 'regexmess: Delete header X-Ham-Report:'); + + +# regex to play with Date: from the FAQ +#@regexmess = 's{\A(.*?(?! ^$))^Date:(.*?)$}{$1Date:$2\nX-Date:$2}gxms' + + +# Change 8bit characters in whole email to X characters + @regexmess = ( 's{[\x80-\xff]}{X}gxms' ) ; + is( 'X-8bit: kaka 1 XX kiki', regexmess('X-8bit: kaka 1 ¤ kiki'), 'regexmess: 1 Change 8bit characters in whole email to X characters'); + +# Same change but using tr + @regexmess = ( 'tr [\x80-\xff] [X]' ) ; + is( 'X-8bit: kaka 1 XXXX kiki', regexmess('X-8bit: kaka 1 ¤£ kiki'), 'regexmess: 2 Change 8bit characters in whole email to X characters, using tr'); + + + +# Add a final \r\n if missing + @regexmess = ( 's{(? +LaSuite: super + +Hello, +Bye. +EOM + , regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: +X-Spam-Report: caca +caca + caca +caca +LaSuite: super + +Hello, +Bye. +EOM + ), 'regexmess: 1 remove buggy X-Spam-Report: across several lines, not the final header'); + + + is( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: +LaSuite: super +LaSuite2: super 2 + +Hello, +Bye. +EOM + , regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: +X-Spam-Report: caca +caca + caca +caca +LaSuite: super +LaSuite2: super 2 + +Hello, +Bye. +EOM + ), 'regexmess: 2 remove buggy X-Spam-Report: across several lines, not the final header'); + + + is( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: +LaSuite: super +LaSuite2: super 2 + +Hello, +Bye. +EOM + , regexmess( +<<'EOM' +X-Spam-Report: caca +caca + caca +caca +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: +LaSuite: super +LaSuite2: super 2 + +Hello, +Bye. +EOM + ), 'regexmess: 3 remove buggy X-Spam-Report: across several lines, first header'); + + + + + is( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye. +EOM + , regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: +X-Spam-Report: caca +caca + caca +caca + +Hello, +Bye. +EOM + ), 'regexmess: 4 remove buggy X-Spam-Report: across several lines, final header'); + + + is( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye. +EOM + , regexmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello, +Bye. +EOM + ), 'regexmess: 5 remove buggy X-Spam-Report: not there at all'); + + + is( +<<"EOM" +Date: Sat, 10 Jul 2010 05:34:45 -0700\r +From:\r +LaSuite: super\r +LaSuite2: super 2\r +\r +Hello,\r +Bye.\r +EOM + , regexmess( +<<"EOM" +X-Spam-Report: caca\r +caca\r + caca\r +caca\r +Date: Sat, 10 Jul 2010 05:34:45 -0700\r +From:\r +LaSuite: super\r +LaSuite2: super 2\r +\r +Hello,\r +Bye.\r +EOM + ), 'regexmess: 6 remove buggy X-Spam-Report: across several lines, first header, with \r'); + + + is( +<<"EOM" +Date: Sat, 10 Jul 2010 05:34:45 -0700\r +From:\r +LaSuite: super\r +LaSuite2: super 2\r +\r +Hello,\r +Bye.\r +EOM + , regexmess( +<<"EOM" +Date: Sat, 10 Jul 2010 05:34:45 -0700\r +From:\r +X-Spam-Report: caca\r +caca\r + caca\r +caca\r +LaSuite: super\r +LaSuite2: super 2\r +\r +Hello,\r +Bye.\r +EOM + ), 'regexmess: 7 remove buggy X-Spam-Report: across several lines, middle header, with \r'); + + + is( +<<"EOM" +Date: Sat, 10 Jul 2010 05:34:45 -0700\r +From:\r +\r +Hello,\r +Bye.\r +EOM + , regexmess( +<<"EOM" +Date: Sat, 10 Jul 2010 05:34:45 -0700\r +From:\r +X-Spam-Report: caca\r +caca\r + caca\r +caca\r +\r +Hello,\r +Bye.\r +EOM + ), 'regexmess: 8 remove buggy X-Spam-Report: across several lines, final header, with \r'); + + + undef @regexmess ; + note( 'Leaving tests_regexmess()' ) ; + return ; +} + +sub regexmess +{ + my ( $string ) = @_ ; + foreach my $regexmess ( @regexmess ) { + $sync->{ debug } and myprint( "eval \$string =~ $regexmess\n" ) ; + my $ret = eval "\$string =~ $regexmess ; 1" ; + #myprint( "eval [$ret]\n" ) ; + if ( ( not $ret ) or $EVAL_ERROR ) { + myprint( "Error: eval regexmess '$regexmess': $EVAL_ERROR" ) ; + return( undef ) ; + } + } + $sync->{ debug } and myprint( "$string\n" ) ; + return( $string ) ; +} + + +sub tests_skipmess +{ + note( 'Entering tests_skipmess()' ) ; + + ok( not( defined skipmess( 'blabla' ) ), 'skipmess, no skipmess, no skip' ) ; + + @skipmess = ('[') ; + ok( not( defined skipmess( 'popopo' ) ), 'skipmess, bad regex [' ) ; + + @skipmess = ('lalala') ; + ok( not( defined skipmess( 'popopo' ) ), 'skipmess, bad regex lalala' ) ; + + @skipmess = ('/popopo/') ; + ok( 1 == skipmess( 'popopo' ), 'skipmess, popopo match regex /popopo/' ) ; + + @skipmess = ('/popopo/') ; + ok( 0 == skipmess( 'rrrrrr' ), 'skipmess, rrrrrr does not match regex /popopo/' ) ; + + @skipmess = ('m{^$}') ; + ok( 1 == skipmess( q{} ), 'skipmess: empty string yes' ) ; + ok( 0 == skipmess( 'Hi!' ), 'skipmess: empty string no' ) ; + + @skipmess = ('m{i}') ; + ok( 1 == skipmess( 'Hi!' ), 'skipmess: i string yes' ) ; + ok( 0 == skipmess( 'Bye!' ), 'skipmess: i string no' ) ; + + @skipmess = ('m{[\x80-\xff]}') ; + ok( 0 == skipmess( 'Hi!' ), 'skipmess: i 8bit no' ) ; + ok( 1 == skipmess( "\xff" ), 'skipmess: \xff 8bit yes' ) ; + + @skipmess = ('m{A}', 'm{B}') ; + ok( 0 == skipmess( 'Hi!' ), 'skipmess: A or B no' ) ; + ok( 0 == skipmess( 'lala' ), 'skipmess: A or B no' ) ; + ok( 0 == skipmess( "\xff" ), 'skipmess: A or B no' ) ; + ok( 1 == skipmess( 'AB' ), 'skipmess: A or B yes' ) ; + ok( 1 == skipmess( 'BA' ), 'skipmess: A or B yes' ) ; + ok( 1 == skipmess( 'AA' ), 'skipmess: A or B yes' ) ; + ok( 1 == skipmess( 'Ok Bye' ), 'skipmess: A or B yes' ) ; + + + @skipmess = ( 'm#\A((?:[^\n]+\n)+|)^Content-Type: Message/Partial;[^\n]*\n(?:\n|.*\n\n)#ism' ) ; # SUPER BEST! + + + + ok( 1 == skipmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +Content-Type: Message/Partial; blabla +From: + +Hello! +Bye. +EOM +), + 'skipmess: 1 match Content-Type: Message/Partial' ) ; + + ok( 0 == skipmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello! +Bye. +EOM +), + 'skipmess: 2 not match Content-Type: Message/Partial' ) ; + + + ok( 1 == skipmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: +Content-Type: Message/Partial; blabla + +Hello! +Bye. +EOM +), + 'skipmess: 3 match Content-Type: Message/Partial' ) ; + + ok( 0 == skipmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello! +Content-Type: Message/Partial; blabla +Bye. +EOM +), + 'skipmess: 4 not match Content-Type: Message/Partial' ) ; + + + ok( 0 == skipmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Hello! +Content-Type: Message/Partial; blabla + +Bye. +EOM +), + 'skipmess: 5 not match Content-Type: Message/Partial' ) ; + + + ok( 1 == skipmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +Content-Type: Message/Partial; blabla +From: + +Hello! + +Content-Type: Message/Partial; blabla + +Bye. +EOM +), + 'skipmess: 6 match Content-Type: Message/Partial' ) ; + + ok( 1 == skipmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +Content-Type: Message/Partial; +From: + +Hello! +Bye. +EOM +), + 'skipmess: 7 match Content-Type: Message/Partial' ) ; + + ok( 1 == skipmess( +<<'EOM' +Date: Wed, 2 Jul 2014 02:26:40 +0000 +MIME-Version: 1.0 +Content-Type: message/partial; + id="TAN_U_P<1404267997.00007489ed17>"; + number=3; + total=3 + +6HQ6Hh3CdXj77qEGixerQ6zHx0OnQ/Cf5On4W0Y6vtU2crABZQtD46Hx1EOh8dDz4+OnTr1G + + +Hello! +Bye. +EOM +), + 'skipmess: 8 match Content-Type: Message/Partial' ) ; + + +ok( 1 == skipmess( +<<'EOM' +Return-Path: +Received: by lamiral.info (Postfix, from userid 1000) + id 21EB12443BF; Mon, 2 Mar 2015 15:38:35 +0100 (CET) +Subject: test: aethaecohngiexao +To: +X-Mailer: mail (GNU Mailutils 2.2) +Message-Id: <20150302143835.21EB12443BF@lamiral.info> +Content-Type: message/partial; + id="TAN_U_P<1404267997.00007489ed17>"; + number=3; + total=3 +Date: Mon, 2 Mar 2015 15:38:34 +0100 (CET) +From: gilles@lamiral.info (Gilles LAMIRAL) + +test: aethaecohngiexao +EOM +), + 'skipmess: 9 match Content-Type: Message/Partial' ) ; + +ok( 1 == skipmess( +<<'EOM' +Date: Mon, 2 Mar 2015 15:38:34 +0100 (CET) +From: gilles@lamiral.info (Gilles LAMIRAL) +Content-Type: message/partial; + id="TAN_U_P<1404267997.00007489ed17>"; + number=3; + total=3 + +test: aethaecohngiexao +EOM +. "lalala\n" x 3_000_000 +), + 'skipmess: 10 match Content-Type: Message/Partial' ) ; + +ok( 0 == skipmess( +<<'EOM' +Date: Mon, 2 Mar 2015 15:38:34 +0100 (CET) +From: gilles@lamiral.info (Gilles LAMIRAL) + +test: aethaecohngiexao +EOM +. "lalala\n" x 3_000_000 +), + 'skipmess: 11 match Content-Type: Message/Partial' ) ; + + +ok( 0 == skipmess( +<<"EOM" +From: fff\r +To: fff\r +Subject: Testing imapsync --skipmess\r +Date: Mon, 22 Aug 2011 08:40:20 +0800\r +Mime-Version: 1.0\r +Content-Type: text/plain; charset=iso-8859-1\r +Content-Transfer-Encoding: 7bit\r +\r +EOM +. qq{!#"d%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefg\r\n } x 32_730 +), + 'skipmess: 12 not match Content-Type: Message/Partial' ) ; + # Complex regular subexpression recursion limit (32766) exceeded with more lines + # exit; + + + undef @skipmess ; + note( 'Leaving tests_skipmess()' ) ; + return ; +} + + +sub tests_skipmess_neg +{ + note( 'Entering tests_skipmess_neg()' ) ; + + + @skipmess = ('m{i}') ; + ok( 1 == skipmess( 'Hi!' ), 'skipmess: i string yes' ) ; + ok( 0 == skipmess( 'Ho!' ), 'skipmess: i string no' ) ; + + @skipmess = ('m{\A(?!.*i)}') ; + ok( 0 == skipmess( 'Hi!' ), 'skipmess: not i string no' ) ; + ok( 1 == skipmess( 'Ho!' ), 'skipmess: not i string yes' ) ; + + + @skipmess = ('m{\A(?!.*^From:[^\n]*tartanpion\@machin\.truc)}xms') ; + + ok( 0 == skipmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Bye. +EOM +), + 'skipmess: 1 not From tartanpion@machin.truc' ) ; + +ok( 1 == skipmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + +Bye. +EOM +), + 'skipmess: 2 not From tartanpion@machin.truc' ) ; + + + + + ok( 0 == skipmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + + From: +Bye. +EOM +), + 'skipmess: 3 not From tartanpion@machin.truc' ) ; + +ok( 1 == skipmess( +<<'EOM' +Date: Sat, 10 Jul 2010 05:34:45 -0700 +From: + + From: +Bye. +EOM +), + 'skipmess: 4 not From tartanpion@machin.truc' ) ; + + + + + undef @skipmess ; + note( 'Leaving tests_skipmess_neg()' ) ; + return ; +} + + +sub skipmess +{ + my ( $string ) = @_ ; + my $match ; + #myprint( "$string\n" ) ; + foreach my $skipmess ( @skipmess ) { + $sync->{ debug } and myprint( "eval \$match = \$string =~ $skipmess\n" ) ; + my $ret = eval "\$match = \$string =~ $skipmess ; 1" ; + #myprint( "eval [$ret]\n" ) ; + $sync->{ debug } and myprint( "match [$match]\n" ) ; + if ( ( not $ret ) or $EVAL_ERROR ) { + myprint( "Error: eval skipmess '$skipmess': $EVAL_ERROR" ) ; + return( undef ) ; + } + return( $match ) if ( $match ) ; + } + return( $match ) ; +} + + + + +sub tests_bytes_display_string_bin +{ + note( 'Entering tests_bytes_display_string_bin()' ) ; + + is( 'NA', bytes_display_string_bin( ), 'bytes_display_string_bin: no args => NA' ) ; + is( 'NA', bytes_display_string_bin( undef ), 'bytes_display_string_bin: undef => NA' ) ; + is( 'NA', bytes_display_string_bin( 'blabla' ), 'bytes_display_string_bin: blabla => NA' ) ; + + is( '0.000 KiB', bytes_display_string_bin( 0 ), 'bytes_display_string_bin: 0 => 0.000 KiB' ) ; + is( '0.001 KiB', bytes_display_string_bin( 1 ), 'bytes_display_string_bin: 1 => 0.001 KiB' ) ; + is( '0.010 KiB', bytes_display_string_bin( 10 ), 'bytes_display_string_bin: 10 => 0.010 KiB' ) ; + is( '0.976 KiB', bytes_display_string_bin( 999 ), 'bytes_display_string_bin: 999 => 0.976 KiB' ) ; + note( bytes_display_string_bin( 999 ) ) ; + + is( '0.999 KiB', bytes_display_string_bin( 1023 ), 'bytes_display_string_bin: 1023 => 0.999 KiB' ) ; + note( bytes_display_string_bin( 1023 ) ) ; + is( '1.000 KiB', bytes_display_string_bin( 1024 ), 'bytes_display_string_bin: 1024 => 1.000 KiB' ) ; + note( bytes_display_string_bin( 1024 ) ) ; + is( '1.001 KiB', bytes_display_string_bin( 1025 ), 'bytes_display_string_bin: 1025 => 1.001 KiB' ) ; + + is( '9.999 KiB', bytes_display_string_bin( 10_239 ), 'bytes_display_string_bin: 10_239 => 9.999 KiB' ) ; + note( bytes_display_string_bin( 10_239 ) ) ; + + is( '10.000 KiB', bytes_display_string_bin( 10_240 ), 'bytes_display_string_bin: 10_240 => 10.000 KiB' ) ; + note( bytes_display_string_bin( 10_240 ) ) ; + + is( '999.999 KiB', bytes_display_string_bin( 1_023_999 ), 'bytes_display_string_bin: 1_023_999 => 999.999 KiB' ) ; + note( bytes_display_string_bin( 1_023_999 ) ) ; + + is( '0.977 MiB', bytes_display_string_bin( 1_024_000 ), 'bytes_display_string_bin: 1_024_000 => 0.977 MiB' ) ; + note( bytes_display_string_bin( 1_024_000 ) ) ; + + is( '0.999 MiB', bytes_display_string_bin( 1_047_527 ), 'bytes_display_string_bin: 1_047_527 => 0.999 MiB' ) ; + note( bytes_display_string_bin( 1_047_527 ) ) ; + + is( '0.999 MiB', bytes_display_string_bin( 1_048_051 ), 'bytes_display_string_bin: 1_048_051 => 0.999 MiB' ) ; + note( bytes_display_string_bin( 1_048_051 ) ) ; + + is( '1.000 MiB', bytes_display_string_bin( 1_048_052 ), 'bytes_display_string_bin: 1_048_052 => 1.000 MiB' ) ; + note( bytes_display_string_bin( 1_048_052 ) ) ; + + is( '1.000 MiB', bytes_display_string_bin( 1_048_575 ), 'bytes_display_string_bin: 1_048_575 => 1.000 MiB' ) ; + is( '1.000 MiB', bytes_display_string_bin( 1_048_576 ), 'bytes_display_string_bin: 1_048_576 => 1.000 MiB' ) ; + + is( '1.000 GiB', bytes_display_string_bin( 1_073_741_823 ), 'bytes_display_string_bin: 1_073_741_823 => 1.000 GiB' ) ; + is( '1.000 GiB', bytes_display_string_bin( 1_073_741_824 ), 'bytes_display_string_bin: 1_073_741_824 => 1.000 GiB' ) ; + + + is( '1.000 TiB', bytes_display_string_bin( 1_099_511_627_775 ), 'bytes_display_string_bin: 1_099_511_627_775 => 1.000 TiB' ) ; + is( '1.000 TiB', bytes_display_string_bin( 1_099_511_627_776 ), 'bytes_display_string_bin: 1_099_511_627_776 => 1.000 TiB' ) ; + + is( '1.000 PiB', bytes_display_string_bin( 1_125_899_906_842_623 ), 'bytes_display_string_bin: 1_125_899_906_842_623 => 1.000 PiB' ) ; + is( '1.000 PiB', bytes_display_string_bin( 1_125_899_906_842_624 ), 'bytes_display_string_bin: 1_125_899_906_842_624 => 1.000 PiB' ) ; + + is( '1024.000 PiB', bytes_display_string_bin( 1_152_921_504_606_846_975 ), 'bytes_display_string_bin: 1_152_921_504_606_846_975 => 1024.000 PiB' ) ; + is( '1024.000 PiB', bytes_display_string_bin( 1_152_921_504_606_846_976 ), 'bytes_display_string_bin: 1_152_921_504_606_846_976 => 1024.000 PiB' ) ; + + is( '1048576.000 PiB', bytes_display_string_bin( 1_180_591_620_717_411_303_424 ), 'bytes_display_string_bin: 1_180_591_620_717_411_303_424 => 1048576.000 PiB' ) ; + note( bytes_display_string_bin( 1_180_591_620_717_411_303_424 ) ) ; + note( bytes_display_string_bin( 3_000_000_000 ) ) ; + note( 'Leaving tests_bytes_display_string_bin()' ) ; + + return ; +} + +sub bytes_display_string_bin +{ + my ( $bytes ) = @_ ; + + my $readable_value = q{} ; + + if ( ! defined( $bytes ) ) { + return( 'NA' ) ; + } + + if ( not match_number( $bytes ) ) { + return( 'NA' ) ; + } + + + + SWITCH: { + if ( abs( $bytes ) < ( 1000 * $KIBI ) ) { + $readable_value = mysprintf( '%.3f KiB', $bytes / $KIBI) ; + last SWITCH ; + } + if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI ) ) { + $readable_value = mysprintf( '%.3f MiB', $bytes / ($KIBI * $KIBI) ) ; + last SWITCH ; + } + if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI * $KIBI) ) { + $readable_value = mysprintf( '%.3f GiB', $bytes / ($KIBI * $KIBI * $KIBI) ) ; + last SWITCH ; + } + if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI * $KIBI * $KIBI) ) { + $readable_value = mysprintf( '%.3f TiB', $bytes / ($KIBI * $KIBI * $KIBI * $KIBI) ) ; + last SWITCH ; + } else { + $readable_value = mysprintf( '%.3f PiB', $bytes / ($KIBI * $KIBI * $KIBI * $KIBI * $KIBI) ) ; + } + # if you have exabytes (EiB) of email to transfer, you have too much email! + } + #myprint( "$bytes = $readable_value\n" ) ; + return( $readable_value ) ; +} + +sub tests_bytes_display_string_dec +{ + note( 'Entering tests_bytes_display_string_dec()' ) ; + + is( 'NA', bytes_display_string_dec( ), 'bytes_display_string_dec: no args => NA' ) ; + is( 'NA', bytes_display_string_dec( undef ), 'bytes_display_string_dec: undef => NA' ) ; + is( 'NA', bytes_display_string_dec( 'blabla' ), 'bytes_display_string_dec: blabla => NA' ) ; + + is( '0 bytes', bytes_display_string_dec( 0 ), 'bytes_display_string_dec: 0 => 0 bytes' ) ; + is( '1 bytes', bytes_display_string_dec( 1 ), 'bytes_display_string_dec: 1 => 1 bytes' ) ; + is( '10 bytes', bytes_display_string_dec( 10 ), 'bytes_display_string_dec: 10 => 10 bytes' ) ; + is( '999 bytes', bytes_display_string_dec( 999 ), 'bytes_display_string_dec: 999 => 999 bytes' ) ; + + is( '1.000 KB', bytes_display_string_dec( 1000 ), 'bytes_display_string_dec: 1000 => 1.000 KB' ) ; + is( '1.001 KB', bytes_display_string_dec( 1001 ), 'bytes_display_string_dec: 1000 => 1.1001 KB' ) ; + + is( '999.999 KB', bytes_display_string_dec( 999_999 ), 'bytes_display_string_dec: 999_999 => 999.999 KB' ) ; + + is( '1.000 MB', bytes_display_string_dec( 1_000_000 ), 'bytes_display_string_dec: 1_000_000 => 1.000 MB' ) ; + is( '1.000 MB', bytes_display_string_dec( 1_000_500 ), 'bytes_display_string_dec: 1_000_500 => 1.000 MB' ) ; + is( '1.001 MB', bytes_display_string_dec( 1_000_501 ), 'bytes_display_string_dec: 1_000_501 => 1.001 MB' ) ; + is( '999.999 MB', bytes_display_string_dec( 999_999_000 ), 'bytes_display_string_dec: 999_999_000 => 999.999 MB' ) ; + is( '999.999 MB', bytes_display_string_dec( 999_999_499 ), 'bytes_display_string_dec: 999_999_499 => 999.999 MB' ) ; + is( '1.000 GB', bytes_display_string_dec( 999_999_500 ), 'bytes_display_string_dec: 999_999_500 => 1.000 GB' ) ; + + is( '1.000 GB', bytes_display_string_dec( 1_000_000_000 ), 'bytes_display_string_dec: 1_000_000_000 => 1.000 GB' ) ; + is( '1.000 GB', bytes_display_string_dec( 1_000_500_000 ), 'bytes_display_string_dec: 1_000_500_000 => 1.000 GB' ) ; + is( '1.001 GB', bytes_display_string_dec( 1_000_500_001 ), 'bytes_display_string_dec: 1_000_501_000 => 1.001 GB' ) ; + is( '999.999 GB', bytes_display_string_dec( 999_999_000_000 ), 'bytes_display_string_dec: 999_999_000_000 => 999.999 GB' ) ; + is( '999.999 GB', bytes_display_string_dec( 999_999_499_999 ), 'bytes_display_string_dec: 999_999_499_999 => 999.999 GB' ) ; + is( '1.000 TB', bytes_display_string_dec( 999_999_500_000 ), 'bytes_display_string_dec: 999_999_500_000 => 1.000 TB' ) ; + + is( '1.000 TB', bytes_display_string_dec( 1_000_000_000_000 ), 'bytes_display_string_dec: 1_000_000_000_000 => 1.000 TB' ) ; + is( '1.000 TB', bytes_display_string_dec( 1_000_500_000_000 ), 'bytes_display_string_dec: 1_000_500_000_000 => 1.000 TB' ) ; + is( '1.001 TB', bytes_display_string_dec( 1_000_500_000_001 ), 'bytes_display_string_dec: 1_000_500_000_000 => 1.000 TB' ) ; + is( '999.999 TB', bytes_display_string_dec( 999_999_000_000_000 ), 'bytes_display_string_dec: 999_999_000_000_000 => 999.999 TB' ) ; + is( '999.999 TB', bytes_display_string_dec( 999_999_499_999_999 ), 'bytes_display_string_dec: 999_999_499_999_999 => 999.999 TB' ) ; + is( '1.000 PB', bytes_display_string_dec( 999_999_500_000_000 ), 'bytes_display_string_dec: 999_999_500_000_000 => 1.000 PB' ) ; + + is( '3.000 GB', bytes_display_string_dec( 3_000_000_000 ), 'bytes_display_string_dec: 3_000_000_000 => 3.000 GB' ) ; + + note( 'Leaving tests_bytes_display_string_dec()' ) ; + return ; +} + +sub bytes_display_string_dec +{ + my ( $bytes ) = @_ ; + + my $readable_value = q{} ; + + if ( ! defined( $bytes ) ) { + return( 'NA' ) ; + } + + if ( not match_number( $bytes ) ) { + return( 'NA' ) ; + } + + SWITCH: { + if ( abs( $bytes ) < ( 1000 ) ) { + $readable_value = mysprintf( '%.0f bytes', $bytes ) ; + last SWITCH ; + } + if ( abs( $bytes ) < ( 1000**2 ) ) { + $readable_value = mysprintf( '%.3f KB', $bytes / 1000 ) ; + last SWITCH ; + } + if ( abs( $bytes ) < ( 999_999_500 ) ) { + $readable_value = mysprintf( '%.3f MB', $bytes / ( 1000**2 ) ) ; + last SWITCH ; + } + if ( abs( $bytes ) < ( 999_999_500_000 ) ) { + $readable_value = mysprintf( '%.3f GB', $bytes / ( 1000**3 ) ) ; + last SWITCH ; + } + if ( abs( $bytes ) < ( 999_999_500_000_000 ) ) { + $readable_value = mysprintf( '%.3f TB', $bytes / ( 1000**4 ) ) ; + last SWITCH ; + } else { + $readable_value = mysprintf( '%.3f PB', $bytes / ( 1000**5 ) ) ; + } + # if you have exabytes (EiB) of email to transfer, you have too much email! + } + #myprint( "$bytes = $readable_value\n" ) ; + + return( $readable_value ) ; +} + + +sub tests_useheader_suggestion +{ + note( 'Entering tests_useheader_suggestion()' ) ; + + is( undef, useheader_suggestion( ), 'useheader_suggestion: no args => undef' ) ; + my $mysync = {} ; + + $mysync->{ h1_nb_msg_noheader } = 0 ; + is( q{}, useheader_suggestion( $mysync ), 'useheader_suggestion: h1_nb_msg_noheader count null => no suggestion' ) ; + $mysync->{ h1_nb_msg_noheader } = 2 ; + is( q{in order to sync those 2 unidentified messages, add option --addheader}, useheader_suggestion( $mysync ), + 'useheader_suggestion: h1_nb_msg_noheader count 2 => suggestion of --addheader' ) ; + + note( 'Leaving tests_useheader_suggestion()' ) ; + return ; +} + +sub useheader_suggestion +{ + my $mysync = shift @ARG ; + if ( ! defined $mysync->{ h1_nb_msg_noheader } ) + { + return ; + } + elsif ( 1 <= $mysync->{ h1_nb_msg_noheader } ) + { + return qq{in order to sync those $mysync->{ h1_nb_msg_noheader } unidentified messages, add option --addheader} ; + } + else + { + return q{} ; + } + return ; +} + +sub do_and_print_stats +{ + my $mysync = shift @ARG ; + + if ( ! $mysync->{can_do_stats} ) { + return ; + } + + my $timeend = time ; + my $timediff = $timeend - $mysync->{timestart} ; + + my $timeend_str = localtimez( $timeend ) ; + + my $cpu_time = cpu_time( $mysync ) ; + my $cpu_percent = cpu_percent( $mysync, $cpu_time, $timediff ) ; + my $cpu_percent_global = cpu_percent_global( $mysync, $cpu_percent ) ; + + my $memory_consumption_at_end = memory_consumption_of_myself( ) || 0 ; + my $memory_consumption_at_start = $mysync->{ memory_consumption_at_start } || 0 ; + my $memory_ratio = ( $mysync->{ biggest_message_transferred } ) ? + mysprintf( '%.1f', $memory_consumption_at_end / $mysync->{ biggest_message_transferred } ) : 'NA' ; + + # my $useheader_suggestion = useheader_suggestion( $mysync ) ; + myprint( "++++ Statistics\n" ) ; + myprint( "Transfer started on : $mysync->{ timestart_str }\n" ) ; + myprint( "Transfer ended on : $timeend_str\n" ) ; + myprintf( "Transfer time : %.1f sec\n", $timediff ) ; + myprint( "Folders synced : $h1_folders_wanted_ct/$h1_folders_wanted_nb synced\n" ) ; + myprint( "Messages transferred : $mysync->{ nb_msg_transferred } " ) ; + myprint( "(could be $nb_msg_skipped_dry_mode without dry mode)" ) if ( $mysync->{dry} ) ; + myprint( "\n" ) ; + myprint( "Messages skipped : $mysync->{ nb_msg_skipped }\n" ) ; + myprint( "Messages found duplicate on host1 : $mysync->{ acc1 }->{ nb_msg_duplicate }\n" ) ; + myprint( "Messages found duplicate on host2 : $mysync->{ acc2 }->{ nb_msg_duplicate }\n" ) ; + myprint( "Messages found crossduplicate on host2 : $mysync->{ h2_nb_msg_crossdup }\n" ) ; + myprint( "Messages void (noheader) on host1 : $mysync->{ h1_nb_msg_noheader } ", useheader_suggestion( $mysync ), "\n" ) ; + myprint( "Messages void (noheader) on host2 : $h2_nb_msg_noheader\n" ) ; + nb_messages_in_1_not_in_2( $mysync ) ; + nb_messages_in_2_not_in_1( $mysync ) ; + myprintf( "Messages found in host1 not in host2 : %s messages\n", $mysync->{ nb_messages_in_1_not_in_2 } ) ; + myprintf( "Messages found in host2 not in host1 : %s messages\n", $mysync->{ nb_messages_in_2_not_in_1 } ) ; + myprint( "Messages deleted on host1 : $mysync->{ acc1 }->{ nb_msg_deleted }\n" ) ; + myprint( "Messages deleted on host2 : $mysync->{ acc2 }->{ nb_msg_deleted }\n" ) ; + myprintf( "Total bytes transferred : %s (%s)\n", + $mysync->{total_bytes_transferred}, + bytes_display_string_bin( $mysync->{total_bytes_transferred} ) ) ; + myprintf( "Total bytes skipped : %s (%s)\n", + $mysync->{ total_bytes_skipped }, + bytes_display_string_bin( $mysync->{ total_bytes_skipped } ) ) ; + $timediff ||= 1 ; # No division per 0 + myprintf("Message rate : %.1f messages/s\n", $mysync->{nb_msg_transferred} / $timediff ) ; + myprintf("Average bandwidth rate : %.1f KiB/s\n", $mysync->{total_bytes_transferred} / $KIBI / $timediff ) ; + myprint( "Reconnections to host1 : $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT}\n" ) ; + myprint( "Reconnections to host2 : $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT}\n" ) ; + + myprintf("Memory consumption at the end : %.1f MiB (*time %.1f MiB*h) (started with %.1f MiB)\n", + $memory_consumption_at_end / $KIBI / $KIBI, + memory_consumption_surface( $mysync, $memory_consumption_at_end, $timediff ), + $memory_consumption_at_start / $KIBI / $KIBI ) ; + + myprint( "Load end is : " . ( join( q{ }, loadavg( ) ) || 'unknown' ), " on $mysync->{cpu_number} cores\n" ) ; + myprint( "CPU time and %cpu : $cpu_time sec $cpu_percent %cpu $cpu_percent_global %allcpus\n" ) ; + myprintf("Biggest message transferred : %s bytes (%s)\n", + $mysync->{ biggest_message_transferred }, + bytes_display_string_bin( $mysync->{ biggest_message_transferred } ) ) ; + myprint( "Memory/biggest message ratio : $memory_ratio\n" ) ; + if ( $mysync->{ foldersizesatend } and $mysync->{ foldersizes } ) { + + + my $nb_msg_start_diff = diff_or_NA( $mysync->{ h2_nb_msg_start }, $mysync->{ h1_nb_msg_start } ) ; + my $bytes_start_diff = diff_or_NA( $mysync->{ h2_bytes_start }, $mysync->{ h1_bytes_start } ) ; + + myprintf("Start difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_start_diff, + $bytes_start_diff, + bytes_display_string_bin( $bytes_start_diff ) ) ; + + my $nb_msg_end_diff = diff_or_NA( $h2_nb_msg_end, $h1_nb_msg_end ) ; + my $bytes_end_diff = diff_or_NA( $h2_bytes_end, $h1_bytes_end ) ; + + myprintf("Final difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_end_diff, + $bytes_end_diff, + bytes_display_string_bin( $bytes_end_diff ) ) ; + } + + comment_on_final_diff_in_1_not_in_2( $mysync ) ; + comment_on_final_diff_in_2_not_in_1( $mysync ) ; + myprint( "Detected $mysync->{nb_errors} errors\n" ) ; + + myprint( $mysync->{ warn_release }, "\n" ) ; + myprint( homepage( ), "\n" ) ; + return ; +} + + + +sub tests_memory_consumption_surface +{ + note( 'Entering tests_memory_consumption_surface()' ) ; + + is( undef, memory_consumption_surface( ), 'memory_consumption_surface: no args => undef' ) ; + my $mysync = { } ; + is( undef, memory_consumption_surface( $mysync ), 'memory_consumption_surface: { } => undef' ) ; + is( "1.0", memory_consumption_surface( $mysync, 1_048_576, 3600 ), 'memory_consumption_surface: 1 MB 1 hour => 1' ) ; + is( "238.4", memory_consumption_surface( $mysync, 500_000_000, 1800 ), 'memory_consumption_surface: 500 MB 30 min => 238' ) ; + + + note( 'Leaving tests_memory_consumption_surface()' ) ; + return ; +} + +sub memory_consumption_surface +{ + my ( $mysync, $memory_consumption_at_end, $timediff ) = @ARG ; + + if ( ! all_defined( $mysync, $memory_consumption_at_end, $timediff ) ) { return } ; + + my $memory_consumption_surface = sprintf( "%.1f", $timediff * $memory_consumption_at_end / $KIBI / $KIBI / 3600 ) ; + + return $memory_consumption_surface ; +} + + + + +sub tests_email_report_message_id +{ + note( 'Entering tests_email_report_message_id()' ) ; + + local $ENV{TZ} = 'GMT' ; + + like( email_report_message_id( ), + qr{^...._.._.._.._.._.._...__\@imapsync.tk$}xms, + 'email_report_message_id: no args => ...._.._.._.._.._.._...__@imapsync.tk' ) ; + + my $mysync = { } ; + like( email_report_message_id( $mysync ), + qr{^...._.._.._.._.._.._...__\@imapsync.tk$}xms, + 'email_report_message_id: undef => ...._.._.._.._.._.._...__@imapsync.tk' ) ; + + $mysync->{ timestart } = 1357902468.531 ; + like( + email_report_message_id( $mysync ), + qr{^2013_01_11_\d\d_07_48_530__\@imapsync.tk$}xms, + 'email_report_message_id: 1357902468.531 => 2013_01_11_\d\d_07_48_530__@imapsync.tk' ) ; + + $mysync->{ user1 } = 'sarah' ; + $mysync->{ user2 } = 'haras' ; + $mysync->{ timestart } = 1357902468.531 ; + like( + email_report_message_id( $mysync ), + qr{^2013_01_11_\d\d_07_48_530_sarah_haras\@imapsync.tk$}xms, + 'email_report_message_id: 1357902468.531 sarah haras => 2013_01_11_\d\d_07_48_530_sarah_haras@imapsync.tk' ) ; + + $mysync->{ user1 } = 'sar@ah' ; + $mysync->{ user2 } = 'har@as' ; + $mysync->{ timestart } = 1357902468.531 ; + like( + email_report_message_id( $mysync ), + qr{2013_01_11_\d\d_07_48_530_sar_ah_har_as\@imapsync.tk}, + 'email_report_message_id: 1357902468.531 sar@ah har@as => 2013_01_11_\d\d_07_48_530_sar_ah_har_as@imapsync.tk' ) ; + + note( 'Leaving tests_email_report_message_id()' ) ; + return ; +} + + +sub email_report_message_id +{ + my $mysync = shift @ARG ; + + my $time = $mysync->{ timestart } || time ; + my $user1_filtered = $mysync->{ user1 } || '' ; + my $user2_filtered = $mysync->{ user2 } || '' ; + + # Nothing but alphanumeric characters and underscores to replace the others + $user1_filtered =~ s/[^a-zA-Z0-9]/_/g ; + $user2_filtered =~ s/[^a-zA-Z0-9]/_/g ; + + my $message_id = join( '', + year_month_day_hour_min_sec_ms( $time ), + '_', + $user1_filtered, + '_', + $user2_filtered, + '@imapsync.tk', + ) ; + return $message_id ; +} + + +sub tests_date_rfc822 +{ + note( 'Entering tests_email_report_date()' ) ; + + ok( date_rfc822( ), 'date_rfc822: no args => now: ' . date_rfc822( ) ) ; + + if ( 'MSWin32' eq $OSNAME ) + { + like( date_rfc822( 1671706800 ), qr{Thu, 22 Dec 2022 \d\d:00:00 \+0000}, 'date_rfc822: 1671706800 => Thu, 22 Dec 2022 \d\d:00:00 \+0000' ) ; + like( date_rfc822( 1671534000 ), qr{Tue, 20 Dec 2022 \d\d:00:00 \+0000}, 'date_rfc822: 1671534000 => Tue, 20 Dec 2022 \d\d:00:00 \+0000' ) ; + + } + else + { + local $ENV{TZ} = 'GMT' ; + is( 'Thu, 01 Jan 1970 00:00:00 +0000', date_rfc822( 0 ), 'date_rfc822: 0 => Thu, 01 Jan 1970 00:00:00 +0000' ) ; + is( 'Thu, 22 Dec 2022 11:00:00 +0000', date_rfc822( 1671706800 ), 'date_rfc822: 1671706800 => Thu, 22 Dec 2022 11:00:00 +0000' ) ; + } + note( 'Leaving tests_email_report_date()' ) ; + return ; +} + + + +sub date_rfc822 +{ + # Later I found Mail::IMAPCLient::Rfc822_date() + # https://metacpan.org/pod/Mail::IMAPClient#Rfc822_date + my $time = shift @ARG ; + $time = defined( $time ) ? $time : time ; + my $old_locale = POSIX::setlocale( POSIX::LC_TIME, "C" ) ; + + my $date_rfc822 ; + + if ( 'MSWin32' eq $OSNAME ) + { + $date_rfc822 = POSIX::strftime( "%a, %d %b %Y %H:%M:%S +0000", localtime( $time ) ) ; + } + else + { + $date_rfc822 = POSIX::strftime( "%a, %d %b %Y %H:%M:%S %z", localtime( $time ) ) ; + } + + POSIX::setlocale( POSIX::LC_TIME, $old_locale ) ; + return $date_rfc822 ; +} + + + +sub tests_email_report_from +{ + note( 'Entering tests_email_report_from()' ) ; + + is( 'help@imapsync.tk', email_report_from( ), 'email_report_from: no args => help@imapsync.tk' ) ; + my $mysync = { } ; + is( 'help@imapsync.tk', email_report_from( $mysync ), 'email_report_from: undef => help@imapsync.tk' ) ; + $mysync->{ email_report_from } = 'foo@example.com' ; + is( 'foo@example.com', email_report_from( $mysync ), 'email_report_from: foo@example.com => foo@example.com' ) ; + + note( 'Leaving tests_email_report_from()' ) ; + return ; +} + +sub email_report_from +{ + my $mysync = shift @ARG ; + + my $email_report_from = defined( $mysync->{ email_report_from } ) + ? $mysync->{ email_report_from } + : 'help@imapsync.tk' ; + + return $email_report_from ; +} + + +sub tests_email_report_to +{ + note( 'Entering tests_email_report_from()' ) ; + + is( 'unknown@imapsync.tk', email_report_to( ), 'email_report_to: no args => help@imapsync.tk' ) ; + my $mysync = { } ; + is( 'unknown@imapsync.tk', email_report_to( $mysync ), 'email_report_to: undef => help@imapsync.tk' ) ; + $mysync->{ user2 } = 'foo@example.com' ; + is( 'foo@example.com', email_report_to( $mysync ), 'email_report_to: foo@example.com => foo@example.com' ) ; + + note( 'Leaving tests_email_report_from()' ) ; + return ; +} + +sub email_report_to +{ + my $mysync = shift @ARG ; + + my $email_report_to = defined( $mysync->{ user2 } ) + ? $mysync->{ user2 } + : 'unknown@imapsync.tk' ; + + return $email_report_to ; +} + +sub email_report_subject +{ + my $mysync = shift @ARG ; + + my $email_report_subject = 'Imapsync transferred your account' ; + return $email_report_subject ; +} + +sub tests_email_report_body_base +{ + note( 'Entering tests_email_report_body_base()' ) ; + + is( '', email_report_body_base( ), 'email_report_body_base: no args => empty string' ) ; + my $mysync = { } ; + is( '', email_report_body_base( $mysync ), 'email_report_body_base: undef => empty string' ) ; + $mysync->{ user1 } = 'user1@example.com' ; + $mysync->{ user2 } = 'user2@example.com' ; + + note( email_report_body_base( $mysync ) ) ; + + note( 'Leaving tests_email_report_body_base()' ) ; + return ; +} + +sub email_report_body_base +{ + my $mysync = shift @ARG ; + + if( ! $mysync ) { return '' ; } + if( ! all_defined( + $mysync->{ user1 }, + $mysync->{ user2 }, + ) ) { return '' ; } + + my $email_report_body_base = <<"EOM"; +\r +\r +\r +Imapsync transfer from $mysync->{ user1 } to $mysync->{ user2 }\r +\r +\r +

Hello!

\r +

\r +Imapsync just ended the synchronization from the imap account $mysync->{ user1 } to the imap account $mysync->{ user2 }.
\r +

\r +EOM + return $email_report_body_base ; +} + +sub email_report_body_extra1 +{ + my $image = '' + .'imapsync website' + .'' + . "\r\n" + ; + return $image ; +} + + +sub email_report_body_extra2 +{ + my $image = '' + .'imapsync website' + .'' + . "\r\n" + ; + return $image ; +} + + + + + +sub email_report_html_begin +{ + return '' + . "\r\n" + ; +} + +sub email_report_html_end +{ + return '' + . "\r\n" + ; +} + +sub email_report_body_begin +{ + return '' + . "\r\n" + ; +} + +sub email_report_body_end +{ + return '' + . "\r\n" + ; +} + + +sub email_report_header +{ + my $mysync = shift @ARG ; + + my @header ; + + push( @header, join( "\r\n", + 'Message-Id: ' . email_report_message_id( $mysync ), + 'Date: ' . date_rfc822( time ), + 'From: ' . email_report_from( $mysync ), + 'To: ' . email_report_to( $mysync ), + 'Subject: ' . email_report_subject( $mysync ), + 'Content-Type: text/html', + "\r\n", + ) + ) ; + + return @header ; +} + + +sub tests_email_report +{ + note( 'Entering tests_email_report()' ) ; + + is( '', email_report( ), 'email_report: undef => empty string' ) ; + my $mysync = { } ; + $mysync->{ user1 } = 'user1@example.com' ; + $mysync->{ user2 } = 'user2@example.com' ; + + note( email_report( $mysync, "c'est extra !\r\n" ) ) ; + + note( 'Leaving tests_email_report()' ) ; + return ; +} + + +sub email_report +{ + my $mysync = shift @ARG ; + + my $extra = shift @ARG ; + + if ( ! defined $mysync ) { return '' ; } + + my @email_report = ( ) ; + + push( @email_report, email_report_header( $mysync ), + email_report_html_begin( ), + email_report_body_begin( ), + email_report_body_base( $mysync ), + $extra, + email_report_body_end( ), + email_report_html_end( ), + ) ; + + my $email_report = join( "", @email_report ) ; + + return $email_report ; +} + +sub email_report_append +{ + my $acc = shift @ARG ; + my $text = shift @ARG ; + + if ( $acc->{ imap }->IsAuthenticated && $text ) + { + my $newuid = $acc->{ imap }->append_string( 'INBOX', $text ) ; + if ( $newuid ) + { + myprint( "$acc->{ Side }: Successfully put the email final report in INBOX. Use --noemailreport" . $acc->{N} . " to avoid it.\n" ) ; + } + else + { + myprint( "$acc->{ Side }: Failed to put the email final report in INBOX. Use --noemailreport" . $acc->{N} . " to avoid it.\n" ) ; + } + return $newuid ; + } + else + { + return ; + } +} + + +sub final_emails_reports +{ + my $mysync = shift @ARG ; + + if ( condition_to_put_final_emails_reports( $mysync ) ) + { + $mysync->{ emailreport2 } and email_report_append( $mysync->{ acc2 }, email_report( $mysync, email_report_body_extra2( ) ) ) ; + $mysync->{ emailreport1 } and email_report_append( $mysync->{ acc1 }, email_report( $mysync, email_report_body_extra1( ) ) ) ; + } + + return ; +} + + +sub condition_to_put_final_emails_reports +{ + my $mysync = shift @ARG ; + + if ( $mysync->{ dry } ) { return 0 ; } + if ( $mysync->{ justfolders } ) { return 0 ; } + + return 1 ; +} + + +sub diff_or_NA +{ + my( $n1, $n2 ) = @ARG ; + + if ( not defined $n1 or not defined $n2 ) { + return 'NA' ; + } + + if ( not match_number( $n1 ) + or not match_number( $n2 ) ) { + return 'NA' ; + } + + return( $n1 - $n2 ) ; +} + +sub match_number +{ + my $n = shift @ARG ; + + if ( not defined $n ) { + return 0 ; + } + if ( $n =~ /[0-9]+\.?[0-9]?/x ) { + return 1 ; + } + else { + return 0 ; + } +} + + +sub tests_match_number +{ + note( 'Entering tests_match_number()' ) ; + + + is( 0, match_number( ), 'match_number: no parameters => 0' ) ; + is( 0, match_number( undef ), 'match_number: undef => 0' ) ; + is( 0, match_number( 'blabla' ), 'match_number: blabla => 0' ) ; + is( 1, match_number( 0 ), 'match_number: 0 => 1' ) ; + is( 1, match_number( 1 ), 'match_number: 1 => 1' ) ; + is( 1, match_number( 1.0 ), 'match_number: 1.0 => 1' ) ; + is( 1, match_number( 0.0 ), 'match_number: 0.0 => 1' ) ; + + note( 'Leaving tests_match_number()' ) ; + return ; +} + + + +sub tests_diff_or_NA +{ + note( 'Entering tests_diff_or_NA()' ) ; + + + is( 'NA', diff_or_NA( ), 'diff_or_NA: no parameters => NA' ) ; + is( 'NA', diff_or_NA( undef ), 'diff_or_NA: undef => NA' ) ; + is( 'NA', diff_or_NA( undef, undef ), 'diff_or_NA: undef undef => NA' ) ; + is( 'NA', diff_or_NA( undef, 1 ), 'diff_or_NA: undef 1 => NA' ) ; + is( 'NA', diff_or_NA( 1, undef ), 'diff_or_NA: 1 undef => NA' ) ; + is( 'NA', diff_or_NA( 'blabla', 1 ), 'diff_or_NA: blabla 1 => NA' ) ; + is( 'NA', diff_or_NA( 1, 'blabla' ), 'diff_or_NA: 1 blabla => NA' ) ; + is( 0, diff_or_NA( 1, 1 ), 'diff_or_NA: 1 1 => 0' ) ; + is( 1, diff_or_NA( 1, 0 ), 'diff_or_NA: 1 0 => 1' ) ; + is( -1, diff_or_NA( 0, 1 ), 'diff_or_NA: 0 1 => -1' ) ; + is( 0, diff_or_NA( 1.0, 1 ), 'diff_or_NA: 1.0 1 => 0' ) ; + is( 1, diff_or_NA( 1.0, 0 ), 'diff_or_NA: 1.0 0 => 1' ) ; + is( -1, diff_or_NA( 0, 1.0 ), 'diff_or_NA: 0 1.0 => -1' ) ; + + note( 'Leaving tests_diff_or_NA()' ) ; + return ; +} + +sub homepage +{ + return( 'Homepage: https://imapsync.lamiral.info/' ) ; +} + + +sub load_modules +{ + if ( $sync->{ssl1} + or $sync->{ssl2} + or $sync->{tls1} + or $sync->{tls2}) { + if ( $sync->{inet4} ) { + IO::Socket::SSL->import( 'inet4' ) ; + } + if ( $sync->{inet6} ) { + IO::Socket::SSL->import( 'inet6' ) ; + } + } + return ; +} + + +# Globals: $skipsize $wholeheaderifneeded +sub parse_header_msg +{ + my ( $mysync, $imap, $m_uid, $folder, $s_heads, $s_fir, $side, $s_hash ) = @_ ; + + my $head = $s_heads->{$m_uid} ; + my $headnum = scalar keys %{ $head } ; + $mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid number of headers, pass one: ", $headnum, "\n" ) ; + + if ( ( ! $headnum ) and ( $wholeheaderifneeded ) ){ + $mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid no header by parse_headers so taking whole header with BODY.PEEK[HEADER]\n" ) ; + $imap->fetch($m_uid, 'BODY.PEEK[HEADER]' ) ; + my $whole_header = $imap->_transaction_literals ; + + #myprint( $whole_header ) ; + $head = decompose_header( $whole_header ) ; + + $headnum = scalar keys %{ $head } ; + $mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid number of headers, pass two: ", $headnum, "\n" ) ; + } + + #myprint( Data::Dumper->Dump( [ $head, \%useheader ] ) ) ; + + my $headstr = header_construct( $mysync, $head, $side, $folder, $m_uid ) ; + + if ( ( ! $headstr ) and ( $mysync->{addheader} ) and ( $side eq 'Host1' ) ) { + my $header = add_header( $m_uid ) ; + $mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid no header found so adding our own [$header]\n" ) ; + $headstr .= uc $header ; + $s_fir->{$m_uid}->{NO_HEADER} = 1; + } + + return if ( ! $headstr ) ; + + my $size = $s_fir->{$m_uid}->{'RFC822.SIZE'} ; + my $flags = $s_fir->{$m_uid}->{'FLAGS'} ; + my $idate = $s_fir->{$m_uid}->{'INTERNALDATE'} ; + $size = length $headstr unless ( $size ) ; + my $m_md5 = md5_base64( $headstr ) ; + + my $key ; + if ( $skipsize ) { + $key = "$m_md5"; + } + else { + $key = "$m_md5:$size"; + } + + if ( exists $s_hash->{"$key"} ) + { + # 0 return code is used to identify duplicate message hash + my $dup_ref = $s_hash->{"$key"}->{'U'} ; + my $num = scalar( @{ $dup_ref } ) ; + push( @{ $dup_ref }, $m_uid ) ; + my $keydup = "$key#$num" ; + $mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid sig $keydup size $size idate $idate dup @{ $dup_ref }\n" ) ; + if ( $mysync->{ syncduplicates } ) + { + $s_hash->{"$keydup"}{'5'} = $m_md5 ; + $s_hash->{"$keydup"}{'s'} = $size ; + $s_hash->{"$keydup"}{'D'} = $idate ; + $s_hash->{"$keydup"}{'F'} = $flags ; + $s_hash->{"$keydup"}{'m'} = $m_uid ; + } + return 0 ; + } + else + { + $s_hash->{"$key"}{'5'} = $m_md5 ; + $s_hash->{"$key"}{'s'} = $size ; + $s_hash->{"$key"}{'D'} = $idate ; + $s_hash->{"$key"}{'F'} = $flags ; + $s_hash->{"$key"}{'m'} = $m_uid ; + $s_hash->{"$key"}{'U'} = [ $m_uid ] ; # ? or [ ] ? + $mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid sig $key size $size idate $idate\n" ) ; + return( 1 ) ; + } + + # we should not be here + return ; +} + +sub tests_header_construct +{ + note( 'Entering tests_header_construct()' ) ; + + is( undef, header_construct( ), 'header_construct: no args => undef' ) ; + my $mysync = {} ; + my $head = { + 'key1' => [ 'val1_key1' ] + } ; + is( undef, header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ), 'header_construct: key1 val1_key1 no useheader => undef' ) ; + + $mysync->{useheader}->{ 'KEY1' } = 1 ; + is( 'KEY1: VAL1_KEY1', header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ), 'header_construct: key1 val1_key1 => KEY1: VAL1_KEY1' ) ; + + + + $head = { + 'key1' => [ 'val1_key1', 'val3_key1', 'val2_key1' ] + } ; + is( 'KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1', header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ), + 'header_construct: key1 val1_key1 val3_key1 val2_key1 => KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1' ) ; + + $head = { + 'key1' => [ 'val1_key1', 'val3_key1', ' val2_key1' ] + } ; + is( 'KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1', header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ), + 'header_construct: key1 val1_key1 val3_key1 val2_key1 => KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1' ) ; + + $mysync->{useheader}->{ 'ALL' } = 1 ; + + is( 'KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1', header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ), + 'header_construct: key1 val1_key1 val3_key1 val2_key1 useheader ALL => KEY1: VAL1_KEY1KEY1: VAL2_KEY1KEY1: VAL3_KEY1' ) ; + + $mysync->{skipheader} = 'key1' ; + is( undef, header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ), + 'header_construct: key1 val1_key1 val3_key1 val2_key1 useheader ALL => undef' ) ; + + $head = { + 'key1' => [ 'val1_key1', 'val3_key1', ' val2_key1' ], + 'key2' => [ 'val1_key2', 'val3_key2', ' val2_key2' ] + } ; + is( 'KEY2: VAL1_KEY2KEY2: VAL2_KEY2KEY2: VAL3_KEY2', header_construct( $mysync, $head, 'Host1', 'INBOX', '1' ), + 'header_construct: ... useheader ALL skipheader key1 => KEY2: VAL1_KEY2KEY2: VAL2_KEY2KEY2: VAL3_KEY2' ) ; + + + note( 'Leaving tests_header_construct()' ) ; + return ; +} + + +# No global in header_construct +sub header_construct +{ + my( $mysync, $head, $side, $folder, $m_uid ) = @_ ; + + my @headstr ; + foreach my $h ( sort keys %{ $head } ) { + next if ( not ( exists $mysync->{useheader}->{ uc $h } ) + and ( not exists $mysync->{useheader}->{ 'ALL' } ) + ) ; + foreach my $val ( @{$head->{$h}} ) { + + my $H = header_line_normalize( $h, $val ) ; + + # show stuff in debug mode + $mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid header [$H]", "\n" ) ; + + if ( $mysync->{skipheader} and $H =~ m/$mysync->{skipheader}/xi) { + $mysync->{ debug } and myprint( "$side: folder/uid $folder/$m_uid skipping header [$H]\n" ) ; + next ; + } + push @headstr, $H ; + } + } + my $headstr = join( '', sort @headstr ) || undef ; + return( $headstr ) ; +} + + +sub header_line_normalize +{ + my( $header_key, $header_val ) = @_ ; + + # no 8-bit data in headers ! + $header_val =~ s/[\x80-\xff]/X/xog; + + # change tabulations to space (Gmail bug on with "Received:" on multilines) + $header_val =~ s/\t/\ /xgo ; + + # remove the first blanks ( dbmail bug? ) + $header_val =~ s/^\s*//xo; + + # remove the last blanks ( Gmail bug ) + $header_val =~ s/\s*$//xo; + + # remove successive blanks ( Mailenable does it ) + $header_val =~ s/\s+/ /xgo; + + # remove Message-Id value domain part ( Mailenable changes it ) + if ( ( $messageidnodomain ) and ( 'MESSAGE-ID' eq uc $header_key ) ) { $header_val =~ s/^([^@]+).*$/$1/xo ; } + + # and uppercase header line + # (dbmail and dovecot) + + my $header_line = uc "$header_key: $header_val" ; + + return( $header_line ) ; +} + +sub tests_header_line_normalize +{ + note( 'Entering tests_header_line_normalize()' ) ; + + + ok( ': ' eq header_line_normalize( q{}, q{} ), 'header_line_normalize: empty args' ) ; + ok( 'HHH: VVV' eq header_line_normalize( 'hhh', 'vvv' ), 'header_line_normalize: hhh vvv ' ) ; + ok( 'HHH: VVV' eq header_line_normalize( 'hhh', ' vvv' ), 'header_line_normalize: remove first blancs' ) ; + ok( 'HHH: AA BB CCC D' eq header_line_normalize( 'hhh', 'aa bb ccc d' ), 'header_line_normalize: remove succesive blanks' ) ; + ok( 'HHH: AA BB CCC' eq header_line_normalize( 'hhh', 'aa bb ccc ' ), 'header_line_normalize: remove last blanks' ) ; + ok( 'HHH: VVV XX YY' eq header_line_normalize( 'hhh', "vvv\t\txx\tyy" ), 'header_line_normalize: tabs' ) ; + ok( 'HHH: XABX' eq header_line_normalize( 'hhh', "\x80AB\xff" ), 'header_line_normalize: 8bit' ) ; + + note( 'Leaving tests_header_line_normalize()' ) ; + return ; +} + + +sub tests_firstline +{ + note( 'Entering tests_firstline()' ) ; + + is( q{}, firstline( 'W/tmp/tests/noexist.txt' ), 'firstline: getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; + + ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'firstline: mkpath W/tmp/tests/' ) ; + + is( "blabla\n" , string_to_file( "blabla\n", 'W/tmp/tests/firstline.txt' ), 'firstline: put blabla in W/tmp/tests/firstline.txt' ) ; + is( 'blabla' , firstline( 'W/tmp/tests/firstline.txt' ), 'firstline: get blabla from W/tmp/tests/firstline.txt' ) ; + + is( q{} , string_to_file( q{}, 'W/tmp/tests/firstline2.txt' ), 'firstline: put empty string in W/tmp/tests/firstline2.txt' ) ; + is( q{} , firstline( 'W/tmp/tests/firstline2.txt' ), 'firstline: get empty string from W/tmp/tests/firstline2.txt' ) ; + + is( "\n" , string_to_file( "\n", 'W/tmp/tests/firstline3.txt' ), 'firstline: put CR in W/tmp/tests/firstline3.txt' ) ; + is( q{} , firstline( 'W/tmp/tests/firstline3.txt' ), 'firstline: get empty string from W/tmp/tests/firstline3.txt' ) ; + + is( "blabla\nTiti\n" , string_to_file( "blabla\nTiti\n", 'W/tmp/tests/firstline4.txt' ), 'firstline: put blabla\nTiti\n in W/tmp/tests/firstline4.txt' ) ; + is( 'blabla' , firstline( 'W/tmp/tests/firstline4.txt' ), 'firstline: get blabla from W/tmp/tests/firstline4.txt' ) ; + + note( 'Leaving tests_firstline()' ) ; + return ; +} + +sub firstline +{ + # extract the first line of a file (without \n) + # return empty string if error or empty string + + my $file = shift @ARG ; + my $line ; + + $line = nthline( $file, 1 ) ; + return $line ; +} + + + +sub tests_secondline +{ + note( 'Entering tests_secondline()' ) ; + + is( q{}, secondline( 'W/tmp/tests/noexist.txt' ), 'secondline: getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; + is( q{}, secondline( 'W/tmp/tests/noexist.txt', 2 ), 'secondline: 2nd getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; + + ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'secondline: mkpath W/tmp/tests/' ) ; + + is( "L1\nL2\nL3\nL4\n" , string_to_file( "L1\nL2\nL3\nL4\n", 'W/tmp/tests/secondline.txt' ), 'secondline: put L1\nL2\nL3\nL4\n in W/tmp/tests/secondline.txt' ) ; + is( 'L2' , secondline( 'W/tmp/tests/secondline.txt' ), 'secondline: get L2 from W/tmp/tests/secondline.txt' ) ; + + + note( 'Leaving tests_secondline()' ) ; + return ; +} + + +sub secondline +{ + # extract the second line of a file (without \n) + # return empty string if error or empty string + + my $file = shift @ARG ; + my $line ; + + $line = nthline( $file, 2 ) ; + return $line ; +} + + + + +sub tests_nthline +{ + note( 'Entering tests_nthline()' ) ; + + is( q{}, nthline( 'W/tmp/tests/noexist.txt' ), 'nthline: getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; + is( q{}, nthline( 'W/tmp/tests/noexist.txt', 2 ), 'nthline: 2nd getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; + + ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'nthline: mkpath W/tmp/tests/' ) ; + is( "L1\nL2\nL3\nL4\n" , string_to_file( "L1\nL2\nL3\nL4\n", 'W/tmp/tests/nthline.txt' ), 'nthline: put L1\nL2\nL3\nL4\n in W/tmp/tests/nthline.txt' ) ; + is( 'L3' , nthline( 'W/tmp/tests/nthline.txt', 3 ), 'nthline: get L3 from W/tmp/tests/nthline.txt' ) ; + + + note( 'Leaving tests_nthline()' ) ; + return ; +} + + +sub nthline +{ + # extract the nth line of a file (without \n) + # return empty string if error or empty string + + my $file = shift @ARG ; + my $num = shift @ARG ; + + if ( ! all_defined( $file, $num ) ) { return q{} ; } + + my $line ; + + $line = ( file_to_array( $file ) )[$num - 1] ; + if ( ! defined $line ) + { + return q{} ; + } + else + { + chomp $line ; + return $line ; + } +} + +sub tests_file_to_array +{ + note( 'Entering tests_file_to_array()' ) ; + + is( undef, file_to_array( ), 'file_to_array: no args => undef' ) ; + is( undef, file_to_array( '/noexist' ), 'file_to_array: /noexist => undef' ) ; + is( undef, file_to_array( '/' ), 'file_to_array: reading a directory => undef' ) ; + + ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'file_to_array: mkpath W/tmp/tests/' ) ; + is( "L1\nL2\nL3\nL4\n" , string_to_file( "L1\nL2\nL3\nL4\n", 'W/tmp/tests/file_to_array.txt' ), 'file_to_array: put L1\nL2\nL3\nL4\n in W/tmp/tests/file_to_array.txt' ) ; + is_deeply( [ "L1\n", "L2\n", "L3\n", "L4\n" ] , [ file_to_array( 'W/tmp/tests/file_to_array.txt' ) ], 'file_to_array: get back L1\n L2\n L3\n L4\n from W/tmp/tests/file_to_array.txt' ) ; + + note( 'Leaving tests_file_to_array()' ) ; + return ; +} + +sub file_to_array +{ + + my( $file ) = shift @ARG ; + if ( ! $file ) { return ; } + if ( ! -e $file ) { return ; } + if ( ! -f $file ) { return ; } + if ( ! -r $file ) { return ; } + + my @string ; + + if ( open my $FILE, '<', $file ) + { + @string = <$FILE> ; + close $FILE ; + return( @string ) ; + } + else + { + myprint( "Error reading file $file : $OS_ERROR\n" ) ; + return ; + } +} + + +sub tests_file_to_string +{ + note( 'Entering tests_file_to_string()' ) ; + + is( undef, file_to_string( ), 'file_to_string: no args => undef' ) ; + is( undef, file_to_string( '/noexist' ), 'file_to_string: /noexist => undef' ) ; + is( undef, file_to_string( '/' ), 'file_to_string: reading a directory => undef' ) ; + ok( file_to_string( $PROGRAM_NAME ), 'file_to_string: reading myself' ) ; + + ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'file_to_string: mkpath W/tmp/tests/' ) ; + + is( 'lilili', string_to_file( 'lilili', 'W/tmp/tests/canbewritten' ), 'file_to_string: string_to_file filling W/tmp/tests/canbewritten with lilili' ) ; + is( 'lilili', file_to_string( 'W/tmp/tests/canbewritten' ), 'file_to_string: reading W/tmp/tests/canbewritten is lilili' ) ; + + is( q{}, string_to_file( q{}, 'W/tmp/tests/empty' ), 'file_to_string: string_to_file filling W/tmp/tests/empty with empty string' ) ; + is( q{}, file_to_string( 'W/tmp/tests/empty' ), 'file_to_string: reading W/tmp/tests/empty is empty' ) ; + + note( 'Leaving tests_file_to_string()' ) ; + return ; +} + +sub file_to_string +{ + my $file = shift @ARG ; + if ( ! $file ) { return ; } + if ( ! -e $file ) { return ; } + if ( ! -f $file ) { return ; } + if ( ! -r $file ) { return ; } + + return( join q{}, file_to_array( $file ) ) ; +} + + +sub tests_string_to_file +{ + note( 'Entering tests_string_to_file()' ) ; + + is( undef, string_to_file( ), 'string_to_file: no args => undef' ) ; + is( undef, string_to_file( 'lalala' ), 'string_to_file: one arg => undef' ) ; + is( undef, string_to_file( 'lalala', '.' ), 'string_to_file: writing a directory => undef' ) ; + ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'string_to_file: mkpath W/tmp/tests/' ) ; + is( 'lalala', string_to_file( 'lalala', 'W/tmp/tests/canbewritten' ), 'string_to_file: W/tmp/tests/canbewritten with lalala' ) ; + is( q{}, string_to_file( q{}, 'W/tmp/tests/empty' ), 'string_to_file: W/tmp/tests/empty with empty string' ) ; + + SKIP: { + Readonly my $NB_UNX_tests_string_to_file => 1 ; + skip( 'Not on Unix non-root', $NB_UNX_tests_string_to_file ) if ('MSWin32' eq $OSNAME or '0' eq $EFFECTIVE_USER_ID ) ; + is( undef, string_to_file( 'lalala', '/cantouch' ), 'string_to_file: /cantouch denied => undef' ) ; + } + + note( 'Leaving tests_string_to_file()' ) ; + return ; +} + +sub string_to_file +{ + my( $string, $file ) = @_ ; + if( ! defined $string ) { return ; } + if( ! defined $file ) { return ; } + + if ( ! -e $file && ! -w dirname( $file ) ) { + myprint( "string_to_file: directory of $file is not writable\n" ) ; + return ; + } + + if ( ! sysopen( FILE, $file, O_WRONLY|O_TRUNC|O_CREAT, 0600) ) { + myprint( "string_to_file: failure writing to $file with error: $OS_ERROR\n" ) ; + return ; + } + print FILE $string ; + close FILE ; + return $string ; +} + +0 and <<'MULTILINE_COMMENT' ; +This is a multiline comment. +Based on David Carter discussion, to do: +* Call parameters stay the same. +* Now always "return( $string, $error )". Descriptions below. +OK * Still capture STDOUT via "1> $output_tmpfile" to finish in $string and "return( $string, $error )" +OK * Now also capture STDERR via "2> $error_tmpfile" to finish in $error and "return( $string, $error )" +OK * in case of CHILD_ERROR, return( undef, $error ) + and print $error, with folder/UID/maybeSubject context, + on console and at the end with the final error listing. Count this as a sync error. +* in case of good command, take final $string as is, unless void. In case $error with value then print it. +* in case of good command and final $string empty, consider it like CHILD_ERROR => + return( undef, $error ) and print $error, with folder/UID/maybeSubject context, + on console and at the end with the final error listing. Count this as a sync error. +MULTILINE_COMMENT +# End of multiline comment. + +sub pipemess +{ + my ( $string, @commands ) = @_ ; + my $error = q{} ; + foreach my $command ( @commands ) { + my $input_tmpfile = "$sync->{ tmpdir }/imapsync_tmp_file.$PROCESS_ID.inp.txt" ; + my $output_tmpfile = "$sync->{ tmpdir }/imapsync_tmp_file.$PROCESS_ID.out.txt" ; + my $error_tmpfile = "$sync->{ tmpdir }/imapsync_tmp_file.$PROCESS_ID.err.txt" ; + string_to_file( $string, $input_tmpfile ) ; + ` $command < $input_tmpfile 1> $output_tmpfile 2> $error_tmpfile ` ; + my $is_command_ko = $CHILD_ERROR ; + my $error_cmd = file_to_string( $error_tmpfile ) ; + chomp( $error_cmd ) ; + $string = file_to_string( $output_tmpfile ) ; + my $string_len = length( $string ) ; + unlink $input_tmpfile, $output_tmpfile, $error_tmpfile ; + + if ( $is_command_ko or ( ! $string_len ) ) { + my $cmd_exit_value = $CHILD_ERROR >> 8 ; + my $cmd_end_signal = $CHILD_ERROR & 127 ; + my $signal_log = ( $cmd_end_signal ) ? " signal $cmd_end_signal and" : q{} ; + my $error_log = qq{Failure: --pipemess command "$command" ended with$signal_log "$string_len" characters exit value "$cmd_exit_value" and STDERR "$error_cmd"\n} ; + myprint( $error_log ) ; + if ( wantarray ) { + return @{ [ undef, $error_log ] } + }else{ + return ; + } + } + if ( $error_cmd ) { + $error .= qq{STDERR of --pipemess "$command": $error_cmd\n} ; + myprint( qq{STDERR of --pipemess "$command": $error_cmd\n} ) ; + } + } + #myprint( "[$string]\n" ) ; + if ( wantarray ) { + return ( $string, $error ) ; + }else{ + return $string ; + } +} + + + +sub tests_pipemess +{ + note( 'Entering tests_pipemess()' ) ; + + + SKIP: { + Readonly my $NB_WIN_tests_pipemess => 3 ; + skip( 'Not on MSWin32', $NB_WIN_tests_pipemess ) if ('MSWin32' ne $OSNAME) ; + # Windows + # "type" command does not accept redirection of STDIN with < + # "sort" does + ok( "nochange\n" eq pipemess( 'nochange', 'sort' ), 'pipemess: nearly no change by sort' ) ; + ok( "nochange2\n" eq pipemess( 'nochange2', qw( sort sort ) ), 'pipemess: nearly no change by sort,sort' ) ; + # command not found + #diag( 'Warning and failure about cacaprout are on purpose' ) ; + ok( ! defined( pipemess( q{}, 'cacaprout' ) ), 'pipemess: command not found' ) ; + + } ; + + my ( $stringT, $errorT ) ; + + SKIP: { + Readonly my $NB_UNX_tests_pipemess => 25 ; + skip( 'Not on Unix', $NB_UNX_tests_pipemess ) if ('MSWin32' eq $OSNAME) ; + # Unix + ok( 'nochange' eq pipemess( 'nochange', 'cat' ), 'pipemess: no change by cat' ) ; + + ok( 'nochange2' eq pipemess( 'nochange2', 'cat', 'cat' ), 'pipemess: no change by cat,cat' ) ; + + ok( " 1\tnumberize\n" eq pipemess( "numberize\n", 'cat -n' ), 'pipemess: numberize by cat -n' ) ; + ok( " 1\tnumberize\n 2\tnumberize\n" eq pipemess( "numberize\nnumberize\n", 'cat -n' ), 'pipemess: numberize by cat -n' ) ; + + ok( "A\nB\nC\n" eq pipemess( "A\nC\nB\n", 'sort' ), 'pipemess: sort' ) ; + + # command not found + #diag( 'Warning and failure about cacaprout are on purpose' ) ; + is( undef, pipemess( q{}, 'cacaprout' ), 'pipemess: command not found' ) ; + + # success with true but no output at all + is( undef, pipemess( q{blabla}, 'true' ), 'pipemess: true but no output' ) ; + + # failure with false and no output at all + is( undef, pipemess( q{blabla}, 'false' ), 'pipemess: false and no output' ) ; + + # Failure since pipemess is not a real pipe, so first cat wait for standard input + is( q{blabla}, pipemess( q{blabla}, '( cat|cat ) ' ), 'pipemess: ok by ( cat|cat )' ) ; + + + ( $stringT, $errorT ) = pipemess( 'nochange', 'cat' ) ; + is( $stringT, 'nochange', 'pipemess: list context, no change by cat, string' ) ; + is( $errorT, q{}, 'pipemess: list context, no change by cat, no error' ) ; + + ( $stringT, $errorT ) = pipemess( 'dontcare', 'true' ) ; + is( $stringT, undef, 'pipemess: list context, true but no output, string' ) ; + like( $errorT, qr{\QFailure: --pipemess command "true" ended with "0" characters exit value "0" and STDERR ""\E}xm, 'pipemess: list context, true but no output, error' ) ; + + ( $stringT, $errorT ) = pipemess( 'dontcare', 'false' ) ; + is( $stringT, undef, 'pipemess: list context, false and no output, string' ) ; + like( $errorT, qr{\QFailure: --pipemess command "false" ended with "0" characters exit value "1" and STDERR ""\E}xm, + 'pipemess: list context, false and no output, error' ) ; + + ( $stringT, $errorT ) = pipemess( 'dontcare', '/bin/echo -n blablabla' ) ; + is( $stringT, q{blablabla}, 'pipemess: list context, "echo -n blablabla", string' ) ; + is( $errorT, q{}, 'pipemess: list context, "echo blablabla", error' ) ; + + + ( $stringT, $errorT ) = pipemess( 'dontcare', '( echo -n blablabla 3>&1 1>&2 2>&3 )' ) ; + is( $stringT, undef, 'pipemess: list context, "no output STDERR blablabla", string' ) ; + like( $errorT, qr{blablabla"}xm, 'pipemess: list context, "no output STDERR blablabla", error' ) ; + + + ( $stringT, $errorT ) = pipemess( 'dontcare', '( echo -n blablabla 3>&1 1>&2 2>&3 )', 'false' ) ; + is( $stringT, undef, 'pipemess: list context, "no output STDERR blablabla then false", string' ) ; + like( $errorT, qr{blablabla"}xm, 'pipemess: list context, "no output STDERR blablabla then false", error' ) ; + + ( $stringT, $errorT ) = pipemess( 'dontcare', 'false', '( echo -n blablabla 3>&1 1>&2 2>&3 )' ) ; + is( $stringT, undef, 'pipemess: list context, "false then STDERR blablabla", string' ) ; + like( $errorT, qr{\QFailure: --pipemess command "false" ended with "0" characters exit value "1" and STDERR ""\E}xm, + 'pipemess: list context, "false then STDERR blablabla", error' ) ; + + ( $stringT, $errorT ) = pipemess( 'dontcare', '( echo rrrrr ; echo -n error_blablabla 3>&1 1>&2 2>&3 )' ) ; + like( $stringT, qr{rrrrr}xm, 'pipemess: list context, "STDOUT rrrrr STDERR error_blablabla", string' ) ; + like( $errorT, qr{STDERR.*error_blablabla}xm, 'pipemess: list context, "STDOUT rrrrr STDERR error_blablabla", error' ) ; + + } + + ( $stringT, $errorT ) = pipemess( 'dontcare', 'cacaprout' ) ; + is( $stringT, undef, 'pipemess: list context, cacaprout not found, string' ) ; + like( $errorT, qr{\QFailure: --pipemess command "cacaprout" ended with "0" characters exit value\E}xm, + 'pipemess: list context, cacaprout not found, error' ) ; + + note( 'Leaving tests_pipemess()' ) ; + return ; +} + + + +sub tests_is_a_release_number +{ + note( 'Entering tests_is_a_release_number()' ) ; + + is( undef, is_a_release_number( ), 'is_a_release_number: no args => undef' ) ; + ok( is_a_release_number( $RELEASE_NUMBER_EXAMPLE_1 ), 'is_a_release_number 1.351' ) ; + ok( is_a_release_number( $RELEASE_NUMBER_EXAMPLE_2 ), 'is_a_release_number 42.4242' ) ; + ok( is_a_release_number( imapsync_version( $sync ) ), 'is_a_release_number imapsync_version( )' ) ; + ok( ! is_a_release_number( 'blabla' ), '! is_a_release_number blabla' ) ; + + note( 'Leaving tests_is_a_release_number()' ) ; + return ; +} + +sub is_a_release_number +{ + my $number = shift @ARG ; + if ( ! defined $number ) { return ; } + return( $number =~ m{^\d+\.\d+$}xo ) ; +} + + + +sub imapsync_version_public +{ + + my $local_version = imapsync_version( $sync ) ; + my $imapsync_basename = imapsync_basename( ) ; + my $context = imapsync_context( ) ; + my $agent_info = "$OSNAME system, perl " + . mysprintf( '%vd', $PERL_VERSION) + . ", Mail::IMAPClient $Mail::IMAPClient::VERSION" + . " $imapsync_basename" + . " $context" ; + my $sock = IO::Socket::INET->new( + PeerAddr => 'imapsync.lamiral.info', + PeerPort => 80, + Proto => 'tcp', + ) ; + return( 'unknown' ) if not $sock ; + print $sock + "GET /prj/imapsync/VERSION HTTP/1.0\r\n", + "User-Agent: imapsync/$local_version ($agent_info)\r\n", + "Host: ks.lamiral.info\r\n\r\n" ; + my @line = <$sock> ; + close $sock ; + my $last_release = $line[$LAST] ; + chomp $last_release ; + return( $last_release ) ; +} + +sub not_long_imapsync_version_public +{ + #myprint( "Entering not_long_imapsync_version_public\n" ) ; + + my $fake = shift @ARG ; + if ( $fake ) { return $fake } + + my $val ; + + # Doesn't work with gethostbyname (see perlipc) + #local $SIG{ALRM} = sub { die "alarm\n" } ; + + if ('MSWin32' eq $OSNAME) { + local $SIG{ALRM} = sub { die "alarm\n" } ; + }else{ + + POSIX::sigaction(SIGALRM, + POSIX::SigAction->new(sub { croak 'alarm' } ) ) + or myprint( "Error setting SIGALRM handler: $OS_ERROR\n" ) ; + } + + my $ret = eval { + alarm 3 ; + { + $val = imapsync_version_public( ) ; + #sleep 4 ; + #myprint( "End of imapsync_version_public\n" ) ; + } + alarm 0 ; + 1 ; + } ; + #myprint( "eval [$ret]\n" ) ; + if ( ( not $ret ) or $EVAL_ERROR ) { + #myprint( "$EVAL_ERROR" ) ; + if ($EVAL_ERROR =~ /alarm/) { + # timed out + return('timeout') ; + }else{ + alarm 0 ; + return( 'unknown' ) ; # propagate unexpected errors + } + }else { + # Good! + return( $val ) ; + } +} + +sub tests_not_long_imapsync_version_public +{ + note( 'Entering tests_not_long_imapsync_version_public()' ) ; + + + is( 1, is_a_release_number( not_long_imapsync_version_public( ) ), + 'not_long_imapsync_version_public: public release is a number' ) ; + + note( 'Leaving tests_not_long_imapsync_version_public()' ) ; + return ; +} + +sub check_last_release +{ + my $fake = shift @ARG ; + my $public_release = not_long_imapsync_version_public( $fake ) ; + $sync->{ debug } and myprint( "check_last_release: [$public_release]\n" ) ; + my $inline_help_when_on = '( Use --noreleasecheck to avoid this release check. )' ; + + if ( $public_release eq 'unknown' ) { + return( 'Imapsync public release is unknown.' . $inline_help_when_on ) ; + } + + if ( $public_release eq 'timeout' ) { + return( 'Imapsync public release is unknown (timeout).' . $inline_help_when_on ) ; + } + + if ( ! is_a_release_number( $public_release ) ) { + return( "Imapsync public release is unknown ($public_release)." . $inline_help_when_on ) ; + } + + my $imapsync_here = imapsync_version( $sync ) ; + + if ( $public_release > $imapsync_here ) { + return( 'This imapsync is not up to date. ' . "( local $imapsync_here < official $public_release )" . $inline_help_when_on ) ; + }else{ + return( 'This imapsync is up to date. ' . "( local $imapsync_here >= official $public_release )" . $inline_help_when_on ) ; + } + + return( 'really unknown' ) ; # Should never arrive here +} + +sub tests_check_last_release +{ + note( 'Entering tests_check_last_release()' ) ; + + diag( check_last_release( 1.1 ) ) ; + # \Q \E here to avoid putting \ before each space + like( check_last_release( 1.1 ), qr/\Qis up to date\E/mxs, 'check_last_release: up to date' ) ; + like( check_last_release( 1.1 ), qr/1\.1/mxs, 'check_last_release: up to date, include number' ) ; + diag( check_last_release( 999.999 ) ) ; + like( check_last_release( 999.999 ), qr/\Qnot up to date\E/mxs, 'check_last_release: not up to date' ) ; + like( check_last_release( 999.999 ), qr/999\.999/mxs, 'check_last_release: not up to date, include number' ) ; + like( check_last_release( 'unknown' ), qr/\QImapsync public release is unknown\E/mxs, 'check_last_release: unknown' ) ; + like( check_last_release( 'timeout' ), qr/\QImapsync public release is unknown (timeout)\E/mxs, 'check_last_release: timeout' ) ; + like( check_last_release( 'lalala' ), qr/\QImapsync public release is unknown (lalala)\E/mxs, 'check_last_release: lalala' ) ; + diag( check_last_release( ) ) ; + + note( 'Leaving tests_check_last_release()' ) ; + return ; +} + +sub tests_imapsync_context +{ + note( 'Entering tests_imapsync_context()' ) ; + + like( imapsync_context( ), qr/^CGI|^Docker|^DockerCGI|^Standard/, 'imapsync_context: CGI or Docker or DockerCGI or Standard' ) ; + note( 'Leaving tests_imapsync_context()' ) ; + return ; +} + +sub imapsync_context +{ + my $mysync = shift @ARG ; + + my $context = q{} ; + + if ( under_docker_context( $mysync ) && under_cgi_context( $mysync ) ) + { + $context = 'DockerCGI' ; + } + elsif ( under_docker_context( $mysync ) ) + { + $context = 'Docker' ; + } + elsif ( under_cgi_context( $mysync ) ) + { + $context = 'CGI' ; + } + else + { + $context = 'Standard' ; + } + + return $context ; + +} + +sub imapsync_version +{ + my $mysync = shift @ARG ; + my $rcs = $mysync->{rcs} ; + my $version ; + + $version = version_from_rcs( $rcs ) ; + return( $version ) ; +} + + +sub tests_version_from_rcs +{ + note( 'Entering tests_version_from_rcs()' ) ; + + is( undef, version_from_rcs( ), 'version_from_rcs: no args => undef' ) ; + is( 1.831, version_from_rcs( q{imapsync,v 1.831 2017/08/27} ), 'version_from_rcs: imapsync,v 1.831 2017/08/27 => 1.831' ) ; + is( 'UNKNOWN', version_from_rcs( 1.831 ), 'version_from_rcs: 1.831 => UNKNOWN' ) ; + + note( 'Leaving tests_version_from_rcs()' ) ; + return ; +} + + +sub version_from_rcs +{ + + my $rcs = shift @ARG ; + if ( ! $rcs ) { return ; } + + my $version = 'UNKNOWN' ; + + if ( $rcs =~ m{,v\s+(\d+\.\d+)}mxso ) { + $version = $1 + } + + return( $version ) ; +} + + +sub tests_imapsync_basename +{ + note( 'Entering tests_imapsync_basename()' ) ; + + ok( imapsync_basename() =~ m/imapsync/, 'imapsync_basename: match imapsync'); + ok( 'blabla' ne imapsync_basename(), 'imapsync_basename: do not equal blabla'); + + note( 'Leaving tests_imapsync_basename()' ) ; + return ; +} + +sub imapsync_basename +{ + + return basename( $PROGRAM_NAME ) ; + +} + + +sub localhost_info +{ + my $mysync = shift @ARG ; + my( $infos ) = join( q{}, + "Here is imapsync ", imapsync_version( $mysync ), + " on host " . hostname(), + ", a $OSNAME system with ", + ram_memory_info( $mysync ), + "\n", + 'with Perl ', + mysprintf( '%vd ', $PERL_VERSION), + "and Mail::IMAPClient $Mail::IMAPClient::VERSION", + ) ; + return( $infos ) ; +} + +sub tests_cpu_number +{ + note( 'Entering tests_cpu_number()' ) ; + + is( 1, is_integer( cpu_number( ) ), "cpu_number: is_integer" ) ; + ok( 1 <= cpu_number( ), "cpu_number: 1 or more" ) ; + is( 1, cpu_number( 1 ), "cpu_number: 1 => 1" ) ; + is( 1, cpu_number( $MINUS_ONE ), "cpu_number: -1 => 1" ) ; + is( 1, cpu_number( 'lalala' ), "cpu_number: lalala => 1" ) ; + is( $NUMBER_42, cpu_number( $NUMBER_42 ), "cpu_number: $NUMBER_42 => $NUMBER_42" ) ; + + note( "cpu_number = " . cpu_number( ) . "\n" ) ; + note( "hostname = " . hostname( ) . "\n" ) ; + SKIP: { + if ( ! ( 'i005' eq hostname() ) ) + { + skip( 'cpu_number on host != i005 (FreeBSD)', 1 ) ; + } + is( 4, cpu_number( ), "cpu_number: on i005 (FreeBSD) => 4" ) ; + } ; + + SKIP: { + if ( ! ( 'petite' eq hostname() ) ) + { + skip( 'cpu_number on host != petite (Linux)', 1 ) ; + } + is( 2, cpu_number( ), "cpu_number: on petite (Linux) => 2" ) ; + #is( 1, cpu_number( ), "cpu_number: on petite (Linux) => 2" ) ; + } ; + + SKIP: { + if ( ! ( skip_macosx( ) ) ) + { + skip( 'cpu_number on host != polarhome macosx (Darwin MacOS X 10.7.5 Lion)', 1 ) ; + } + is( 2, cpu_number( ), "cpu_number: on polarhome macosx (Darwin MacOS X 10.7.5 Lion) => 2" ) ; + } ; + + SKIP: { + if ( ! ( 'pcHPDV7-HP' eq hostname() ) ) + { + skip( 'cpu_number on host != pcHPDV7-HP (Windows 7, 64bits)', 1 ) ; + } + is( 2, cpu_number( ), "cpu_number: on pcHPDV7-HP (Windows 7, 64bits) => 2" ) ; + } ; + + SKIP: { + if ( ! ( 'CUILLERE' eq hostname() ) ) + { + skip( 'cpu_number on host != CUILLERE (Windows XP, 32bits)', 1 ) ; + } + is( 1, cpu_number( ), "cpu_number: on CUILLERE (Windows XP, 32bits) => 1" ) ; + } ; + + + note( 'Leaving tests_cpu_number()' ) ; + return ; +} + + +sub cpu_number { + + my $cpu_number_forced = shift @ARG ; + # Well, here 1 is better than 0 or undef + my $cpu_number = 1 ; # Default value, erased if better found + + my @cpuinfo ; + if ( $ENV{"NUMBER_OF_PROCESSORS"} ) + { + # might be under a Windows system + $cpu_number = $ENV{"NUMBER_OF_PROCESSORS"} ; + #myprint( "Number of processors found by env var NUMBER_OF_PROCESSORS: $cpu_number\n" ) ; + } + + if ( 'darwin' eq $OSNAME ) + { + $cpu_number = backtick( "sysctl -n hw.ncpu" ) ; + chomp( $cpu_number ) ; + #myprint( "Number of processors found by cmd 'sysctl -n hw.ncpu': $cpu_number\n" ) ; + } + + if ( 'freebsd' eq $OSNAME ) + { + $cpu_number = backtick( "sysctl -n kern.smp.cpus" ) ; + chomp( $cpu_number ) ; + #myprint( "Number of processors found by cmd 'sysctl -n kern.smp.cpus': $cpu_number\n" ) ; + } + + if ( 'linux' eq $OSNAME && -e '/proc/cpuinfo' ) + { + @cpuinfo = file_to_array( '/proc/cpuinfo' ) ; + $cpu_number = grep { /^processor/mxs } @cpuinfo ; + #myprint( "Number of processors found via /proc/cpuinfo: $cpu_number\n" ) ; + } + + if ( defined $cpu_number_forced ) + { + $cpu_number = $cpu_number_forced ; + } + + return( integer_or_1( $cpu_number ) ) ; +} + +sub tests_integer_or_1 +{ + note( 'Entering tests_integer_or_1()' ) ; + + is( 1, integer_or_1( ), 'integer_or_1: no args => 1' ) ; + is( 1, integer_or_1( undef ), 'integer_or_1: undef => 1' ) ; + is( $NUMBER_10, integer_or_1( $NUMBER_10 ), 'integer_or_1: 10 => 10' ) ; + is( 1, integer_or_1( q{} ), 'integer_or_1: empty string => 1' ) ; + is( 1, integer_or_1( 'lalala' ), 'integer_or_1: lalala => 1' ) ; + + note( 'Leaving tests_integer_or_1()' ) ; + return ; +} + +sub integer_or_1 +{ + my $number = shift @ARG ; + if ( is_integer( $number ) ) { + return $number ; + } + # else + return 1 ; +} + +sub tests_is_integer +{ + note( 'Entering tests_is_integer()' ) ; + + is( undef, is_integer( ), 'is_integer: no args => undef ' ) ; + ok( is_integer( 1 ), 'is_integer: 1 => yes ') ; + ok( is_integer( $NUMBER_42 ), 'is_integer: 42 => yes ') ; + ok( is_integer( "$NUMBER_42" ), 'is_integer: "$NUMBER_42" => yes ') ; + ok( is_integer( '42' ), 'is_integer: "42" => yes ') ; + ok( is_integer( $NUMBER_104_857_600 ), 'is_integer: 104_857_600 => yes') ; + ok( is_integer( "$NUMBER_104_857_600" ), 'is_integer: "$NUMBER_104_857_600" => yes') ; + ok( is_integer( '104857600' ), 'is_integer: 104857600 => yes') ; + ok( ! is_integer( 'blabla' ), 'is_integer: blabla => no' ) ; + ok( ! is_integer( q{} ), 'is_integer: empty string => no' ) ; + + note( 'Leaving tests_is_integer()' ) ; + return ; +} + +sub is_integer +{ + my $number = shift @ARG ; + if ( ! defined $number ) { return ; } + return( $number =~ m{^\d+$}xo ) ; +} + + + + +sub tests_loadavg +{ + note( 'Entering tests_loadavg()' ) ; + + SKIP: { + skip( 'Tests for darwin', 3 ) if ('darwin' ne $OSNAME) ; + is( undef, loadavg( '/noexist' ), 'loadavg: /noexist => undef' ) ; + is_deeply( + [ '0.11', '0.22', '0.33' ], + [ loadavg( 'vm.loadavg: { 0.11 0.22 0.33 }' ) ], + 'loadavg: "vm.loadavg: { 0.11 0.22 0.33 }" => 0.11 0.22 0.33' + ) ; + note( join( " ", "loadavg:", loadavg( ) ) ) ; + is( 3, scalar( my @loadavg = loadavg( ) ), 'loadavg: 3 values' ) ; + } ; + + SKIP: { + skip( 'Tests for linux', 3 ) if ('linux' ne $OSNAME) ; + is( undef, loadavg( '/noexist' ), 'loadavg: /noexist => undef' ) ; + ok( loadavg( ), 'loadavg: no args' ) ; + + is_deeply( [ '0.39', '0.30', '0.37', '1/602' ], + [ loadavg( '0.39 0.30 0.37 1/602 6073' ) ], + 'loadavg 0.39 0.30 0.37 1/602 6073 => [0.39, 0.30, 0.37, 1/602]' ) ; + } ; + + SKIP: { + skip( 'Tests for Windows', 1 ) if ('MSWin32' ne $OSNAME) ; + is_deeply( [ 0 ], + [ loadavg( ) ], + 'loadavg on MSWin32 => 0' ) ; + } ; + + note( 'Leaving tests_loadavg()' ) ; + return ; +} + + +sub loadavg +{ + if ( 'linux' eq $OSNAME ) { + return ( loadavg_linux( @ARG ) ) ; + } + if ( 'freebsd' eq $OSNAME ) { + return ( loadavg_freebsd( @ARG ) ) ; + } + if ( 'darwin' eq $OSNAME ) { + return ( loadavg_darwin( @ARG ) ) ; + } + if ( 'MSWin32' eq $OSNAME ) { + return ( loadavg_windows( @ARG ) ) ; + } + return( 'unknown' ) ; +} + +sub loadavg_linux +{ + my $line = shift @ARG ; + + if ( ! $line ) { + $line = firstline( '/proc/loadavg' ) or return ; + } + + my ( $avg_1_min, $avg_5_min, $avg_15_min, $current_runs ) = split /\s/mxs, $line ; + if ( all_defined( $avg_1_min, $avg_5_min, $avg_15_min ) ) { + $sync->{ debug } and myprint( "System load: $avg_1_min $avg_5_min $avg_15_min $current_runs\n" ) ; + return ( $avg_1_min, $avg_5_min, $avg_15_min, $current_runs ) ; + } + return ; +} + +sub loadavg_freebsd +{ + my $file = shift @ARG ; + # Example of output of command "sysctl vm.loadavg": + # vm.loadavg: { 0.15 0.08 0.08 } + my $loadavg ; + + if ( ! defined $file ) { + eval { + $loadavg = `LANG=C /sbin/sysctl vm.loadavg` ; + #myprint( "LOADAVG FREEBSD: $loadavg\n" ) ; + } ; + if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; } + }else{ + $loadavg = firstline( $file ) or return ; + } + + my ( $avg_1_min, $avg_5_min, $avg_15_min ) + = $loadavg =~ /vm\.loadavg\s*[:=]\s*\{?\s*(\d+\.?\d*)\s+(\d+\.?\d*)\s+(\d+\.?\d*)/mxs ; + $sync->{ debug } and myprint( "System load: $avg_1_min $avg_5_min $avg_15_min\n" ) ; + return ( $avg_1_min, $avg_5_min, $avg_15_min ) ; +} + +sub loadavg_darwin +{ + my $line = shift @ARG ; + # Example of output of command "sysctl vm.loadavg": + # vm.loadavg: { 0.15 0.08 0.08 } + my $loadavg ; + + if ( ! defined $line ) { + eval { + # $loadavg = `/usr/sbin/sysctl vm.loadavg` ; + $loadavg = `LANG=C /usr/sbin/sysctl vm.loadavg` ; + #myprint( "LOADAVG DARWIN: $loadavg\n" ) ; + } ; + if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; } + }else{ + $loadavg = $line ; + } + + my ( $avg_1_min, $avg_5_min, $avg_15_min ) + = $loadavg =~ /vm\.loadavg\s*[:=]\s*\{?\s*(\d+\.?\d*)\s+(\d+\.?\d*)\s+(\d+\.?\d*)/mxs ; + #$sync->{ debug } and myprint( "System load: $avg_1_min $avg_5_min $avg_15_min\n" ) ; + return ( $avg_1_min, $avg_5_min, $avg_15_min ) ; +} + +sub loadavg_windows +{ + my $file = shift @ARG ; + # Example of output of command "wmic cpu get loadpercentage": + # LoadPercentage + # 12 + my $loadavg ; + + if ( ! defined $file ) { + eval { + #$loadavg = `CMD wmic cpu get loadpercentage` ; + $loadavg = "LoadPercentage\n0\n" ; + #myprint( "LOADAVG WIN: $loadavg\n" ) ; + } ; + if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; } + }else{ + $loadavg = file_to_string( $file ) or return ; + #myprint( "$loadavg" ) ; + } + $loadavg =~ /LoadPercentage\n(\d+)/xms ; + my $num = $1 ; + $num /= 100 ; + + $sync->{ debug } and myprint( "System load: $num\n" ) ; + return ( $num ) ; +} + + + + + + +sub tests_load_and_delay +{ + note( 'Entering tests_load_and_delay()' ) ; + + is( undef, load_and_delay( ), 'load_and_delay: no args => undef ' ) ; + is( undef, load_and_delay( 1, 2 ), 'load_and_delay: not 3 args => undef ' ) ; + is( undef, load_and_delay( 2, 0, 1, 1, 1 ), 'load_and_delay: division per 0 => undef ' ) ; + +# ( $max_load_per_core, $cpu_num, $avg_1_min, $avg_5_min, $avg_15_min ) + + # load max = 1 per cpu + is( 0, load_and_delay( 1, 1, 0 ), 'load_and_delay: max=1, one core, loads is 0 => ok ' ) ; + is( 0, load_and_delay( 1, 1, 0, 0, 0 ), 'load_and_delay: max=1, one core, loads are all 0 => ok ' ) ; + is( 0, load_and_delay( 3, 1, 1, 1, 1, 1 ), 'load_and_delay: six arguments => ok' ) ; + is( 0, load_and_delay( 1, 2, 1, 1, 1 ), 'load_and_delay: max=1, two core, loads are all 1 => ok ' ) ; + is( 0, load_and_delay( 1, 2, 1, 4, 5 ), 'load_and_delay: max=1, two core, load1m is 1 => ok ' ) ; + is( 0, load_and_delay( 1, 1, 0, 0, 0 ), 'load_and_delay: max=1, one core, load1m=0 load5m=0 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, 0, 0, 2 ), 'load_and_delay: max=1, one core, load1m=0 load5m=0 load15m=2 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, 0, 2, 0 ), 'load_and_delay: max=1, one core, load1m=0 load5m=2 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, 0, 2, 2 ), 'load_and_delay: max=1, one core, load1m=0 load5m=2 load15m=2 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, 0, 3, 3 ), 'load_and_delay: max=1, one core, load1m=0 load5m=3 load15m=3 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, 0, 4, 4 ), 'load_and_delay: max=1, one core, load1m=0 load5m=3 load15m=3 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, .2, 0, 0 ), 'load_and_delay: max=1, one core, load1m=.2 load5m=0 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, .2, 0, .2 ), 'load_and_delay: max=1, one core, load1m=.2 load5m=0 load15m=.2 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, .2, .2, 0 ), 'load_and_delay: max=1, one core, load1m=2 load5m=2 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 1, 1, .2, .2, .2 ), 'load_and_delay: max=1, one core, load1m=.2 load5m=.2 load15m=.2 => 0 ' ) ; + is( 1, load_and_delay( 1, 1, 1, 0, 0 ), 'load_and_delay: max=1, one core, load1m=3 load5m=0 load15m=0 => 0 ' ) ; + is( 1, load_and_delay( 1, 1, 1, .9, .9 ), 'load_and_delay: max=1, one core, load1m=3 load5m=.9 load15m=.9 => 0 ' ) ; + is( 5, load_and_delay( 1, 1, 1, 1, .9 ), 'load_and_delay: max=1, one core, load1m=3 load5m=3 load15m=.9 => 5 ' ) ; + is( 15, load_and_delay( 1, 1, 1, 1, 1 ), 'load_and_delay: max=1, one core, load1m=3 load5m=3 load15m=3 => 15 ' ) ; + is( 0, load_and_delay( 1, 1, .9, .9, .9 ), 'load_and_delay: max=1, one core, load1m=.9 load5m=.9 load15m=.9 => 0 ' ) ; + + # load max = 3 per cpu + is( 0, load_and_delay( 3, 1, 1, 1, 1 ), 'load_and_delay: max=3, one core, loads are all 1 => ok ' ) ; + is( 0, load_and_delay( 3, 2, 2, 2, 2 ), 'load_and_delay: max=3, two core, loads are all 2 => ok ' ) ; + is( 0, load_and_delay( 3, 2, 2, 4, 5 ), 'load_and_delay: max=3, two core, load1m is 2 => ok ' ) ; + is( 0, load_and_delay( 3, 1, 0, 0, 0 ), 'load_and_delay: max=3, one core, load1m=0 load5m=0 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 0, 0, 2 ), 'load_and_delay: max=3, one core, load1m=0 load5m=0 load15m=2 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 0, 2, 0 ), 'load_and_delay: max=3, one core, load1m=0 load5m=2 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 0, 2, 2 ), 'load_and_delay: max=3, one core, load1m=0 load5m=2 load15m=2 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 0, 3, 3 ), 'load_and_delay: max=3, one core, load1m=0 load5m=3 load15m=3 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 0, 4, 4 ), 'load_and_delay: max=3, one core, load1m=0 load5m=3 load15m=3 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 2, 0, 0 ), 'load_and_delay: max=3, one core, load1m=2 load5m=0 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 2, 0, 2 ), 'load_and_delay: max=3, one core, load1m=2 load5m=0 load15m=2 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 2, 2, 0 ), 'load_and_delay: max=3, one core, load1m=2 load5m=2 load15m=0 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 2, 2, 2 ), 'load_and_delay: max=3, one core, load1m=2 load5m=2 load15m=2 => 0 ' ) ; + is( 1, load_and_delay( 3, 1, 3, 0, 0 ), 'load_and_delay: max=3, one core, load1m=3 load5m=0 load15m=0 => 0 ' ) ; + is( 1, load_and_delay( 3, 1, 3, 2.9, 2.9 ), 'load_and_delay: max=3, one core, load1m=3 load5m=2.9 load15m=2.9 => 0 ' ) ; + is( 5, load_and_delay( 3, 1, 3, 3, 2.9 ), 'load_and_delay: max=3, one core, load1m=3 load5m=3 load15m=2.9 => 0 ' ) ; + is( 15, load_and_delay( 3, 1, 3, 3, 3 ), 'load_and_delay: max=3, one core, load1m=3 load5m=3 load15m=3 => 0 ' ) ; + is( 0, load_and_delay( 3, 1, 2.9, 2.9, 2.9 ), 'load_and_delay: max=3, one core, load1m=2.9 load5m=2.9 load15m=2.9 => 0 ' ) ; + + + + is( 1, load_and_delay( 6, 1, 6, 0, 0 ), 'load_and_delay: max=6, one core, load1m=6 load5m=0 load15m=0 => 1 ' ) ; + is( 1, load_and_delay( 6, 1, 6, 5.9, 5.9 ), 'load_and_delay: max=6, one core, load1m=6 load5m=5.9 load15m=5.9 => 1 ' ) ; + is( 5, load_and_delay( 6, 1, 6, 6, 5.9 ), 'load_and_delay: max=6, one core, load1m=6 load5m=6 load15m=5.9 => 5 ' ) ; + is( 15, load_and_delay( 6, 1, 6, 6, 6 ), 'load_and_delay: max=6, one core, load1m=6 load5m=6 load15m=6 => 15 ' ) ; + is( 0, load_and_delay( 6, 1, 5.9, 5.9, 5.9 ), 'load_and_delay: max=6, one core, load1m=5.9 load5m=5.9 load15m=5.9 => 1 ' ) ; + + note( 'Leaving tests_load_and_delay()' ) ; + return ; +} + +sub load_and_delay +{ + # Basically return 0 if load is not heavy, ie load 1 min <= $max_load_per_core + + # 5 arguments at least (loadavg return 4 arguments like "0.19 0.16 0.17 3/444" ) + if ( 3 > scalar @ARG ) { return ; } + + my ( $max_load_per_core, $cpu_num, $avg_1_min, $avg_5_min, $avg_15_min ) = @ARG ; + + if ( 0 == $cpu_num ) { return ; } + + # No avg_5_min nor avg_15_min on Windows + $avg_5_min ||= 0 ; + $avg_15_min ||= 0 ; + + # Let divide by number of cores + ( $avg_1_min, $avg_5_min, $avg_15_min ) = map { $_ / $cpu_num } ( $avg_1_min, $avg_5_min, $avg_15_min ) ; + + # If one period 1m is ok => ok ( 0 ) else Nok ( return > 0, 1 or 5 or 15 ) + if ( $avg_1_min < $max_load_per_core ) { return 0 ; } + if ( $avg_5_min < $max_load_per_core ) { return 1 ; } # Message: retry in 1 minute + if ( $avg_15_min < $max_load_per_core ) { return 5 ; } # Message: retry in 5 minutes + return 15 ; # Message: retry in 15 minutes +} + + +sub tests_cpu_time +{ + note( 'Entering tests_cpu_time()' ) ; + + ok( is_number( cpu_time( ) ), 'cpu_time: no args => a number' ) ; + + my $mysync = { } ; + $mysync->{ debug } = 1 ; + ok( is_number( cpu_time( $mysync ) ), 'cpu_time: {} => a number' ) ; + + note( 'Leaving tests_cpu_time()' ) ; + return ; +} + +sub cpu_time +{ + my $mysync = shift @ARG ; + + my @cpu_times = times ; + if ( ! @cpu_times ) { return ; } + + my $cpu_time = 0 ; + # last element is the sum of all elements + $cpu_time = ( map { $cpu_time += $_ } @cpu_times )[ -1 ] ; + my $cpu_time_rounded = mysprintf( '%.2f', $cpu_time ) ; + $mysync->{ debug } and myprint( join(' + ', @cpu_times), " = $cpu_time ~ $cpu_time_rounded\n" ) ; + return $cpu_time ; +} + + +sub tests_cpu_percent +{ + note( 'Entering tests_cpu_percent()' ) ; + + is( '0.0', cpu_percent( ), 'cpu_percent: no args => 0.0' ) ; + my $mysync = { } ; + $mysync->{ debug } = 1 ; + is( '0.0', cpu_percent( $mysync ), 'cpu_percent: {} => 0.0' ) ; + is( '0.0', cpu_percent( $mysync, 0 ), 'cpu_percent: {} 0 => 0.0' ) ; + is( '300.0', cpu_percent( $mysync, 3 ), 'cpu_percent: {} 3 => 300.0' ) ; + is( '30.0', cpu_percent( $mysync, 3, 10 ), 'cpu_percent: {} 3 10 => 30.0' ) ; + is( '0.0', cpu_percent( $mysync, 0, 10 ), 'cpu_percent: {} 0 10 => 0.0' ) ; + + note( 'Leaving tests_cpu_percent()' ) ; + return ; +} + +sub cpu_percent +{ + my $mysync = shift @ARG ; + my $cpu_time = shift || 0 ; + my $timediff = shift || 1 ; # no division by 0 + + if ( $cpu_time > $timediff ) + { + myprint( "Strange: cpu_time $cpu_time > timediff $timediff\n" ) ; + } + my $cpu_percent = 0 ; + $cpu_percent = mysprintf( '%.1f', 100 * $cpu_time / $timediff ) ; + $mysync->{ debug } and myprint( "cpu_percent: $cpu_percent \n" ) ; + + return $cpu_percent ; + +} + +sub tests_cpu_percent_global +{ + note( 'Entering tests_cpu_percent_global()' ) ; + + is( '0.0', cpu_percent_global( ), 'cpu_percent_global: no args => 0' ) ; + my $mysync = { } ; + $mysync->{ debug } = 1 ; + is( '0.0', cpu_percent_global( $mysync ), 'cpu_percent_global: {} => 0' ) ; + is( '0.0', cpu_percent_global( $mysync, 0 ), 'cpu_percent_global: {} 0 => 0' ) ; + + SKIP: { + if ( ! ( 'i005' eq hostname() ) ) + { + skip( 'cpu_percent_global on host != i005', 1 ) ; + } + is( '25.0', cpu_percent_global( $mysync, 100 ), 'cpu_percent_global: {} 100 => 25 on host i005' ) ; + } ; + + SKIP: { + if ( ! ( 'petite' eq hostname() ) ) + { + skip( 'cpu_percent_global on host != petite', 1 ) ; + } + is( '50.0', cpu_percent_global( $mysync, 100 ), 'cpu_percent_global: {} 100 => 50 on host petite' ) ; + #is( '100.0', cpu_percent_global( $mysync, 100 ), 'cpu_percent_global: {} 100 => 100 on host petite' ) ; + } ; + + note( 'Leaving tests_cpu_percent_global()' ) ; + return ; +} + +sub cpu_percent_global +{ + my $mysync = shift @ARG ; + my $cpu_percent = shift || 0 ; + + my $cpu_number = cpu_number( ) ; + + my $cpu_percent_global ; + $cpu_percent_global = mysprintf( '%.1f', $cpu_percent / $cpu_number ) ; + $mysync->{ debug } and myprint( "cpu_percent_global: $cpu_percent_global \n" ) ; + + return( $cpu_percent_global ) ; +} + + +sub tests_ram_memory_info +{ + note( 'Entering tests_ram_memory_info()' ) ; + + note( "ram_memory_info:", ram_memory_info( ) ) ; + note( "total_ram_memory_bytes_sys_meminfo:", total_ram_memory_bytes_sys_meminfo( ) ) ; + #note( "total_ram_memory_bytes_hw_memsize:", total_ram_memory_bytes_hw_memsize( ) ) ; + + ok( ram_memory_info( ), 'ram_memory_info: => some text' ) ; + + note( 'Leaving tests_ram_memory_info()' ) ; + return ; +} + + +sub total_ram_memory_bytes +{ + my $total_ram_memory_bytes ; + + # Found Sys::MemInfo::get( "totalmem" ) + # wrong on macOS 11.5.2 (20G95) + # good on Mac OS X 10.7.5 (11G63) + # ( commands "sw_vers" or "system_profiler SPSoftwareDataType" ) + + if ( 'darwin' eq $OSNAME ) + { + $total_ram_memory_bytes = total_ram_memory_bytes_hw_memsize( ) ; + } + else + { + $total_ram_memory_bytes = total_ram_memory_bytes_sys_meminfo( ) ; + } +} + + + +sub total_ram_memory_bytes_hw_memsize +{ + my $total_ram_memory_bytes = `sysctl -n hw.memsize` ; + chomp $total_ram_memory_bytes ; + return $total_ram_memory_bytes ; +} + + +sub total_ram_memory_bytes_sys_meminfo +{ + my $total_ram_memory_bytes = Sys::MemInfo::get( "totalmem" ) ; + return $total_ram_memory_bytes ; +} + + + + +sub ram_memory_info +{ + my $mysync = shift @ARG ; + # In GigaBytes so division by 1024 * 1024 * 1024 + # + + my $ram_memory_info = sprintf( + "%.1f/%.1f free GiB of RAM", + Sys::MemInfo::get("freemem") / ( $KIBI ** 3 ), + total_ram_memory_bytes( ) / ( $KIBI ** 3 ), + ) ; + + my $memory_consumption_all_pids_percent = memory_consumption_all_pids_percent( $mysync ) || 0 ; + if ( $memory_consumption_all_pids_percent ) + { + $ram_memory_info .= ", $memory_consumption_all_pids_percent% used by processes." + } + + return $ram_memory_info ; +} + + + +sub tests_memory_stress +{ + note( 'Entering tests_memory_stress()' ) ; + my $mysync = { } ; + sig_install( $mysync, 'catch_ignore', ( 'QUIT', 'TERM', 'INT' ) ) ; + is( undef, memory_stress( ), 'memory_stress: => undef' ) ; + + note( 'Leaving tests_memory_stress()' ) ; + return ; +} + +sub memory_stress +{ + my $total_ram_in_MB = total_ram_memory_bytes( ) / ( $KIBI * $KIBI ) ; + my $i = 1 ; + + myprintf("Stress memory consumption before: %.1f MiB of %.1f MiB\n", memory_consumption_of_myself( ) / $KIBI / $KIBI, $total_ram_in_MB ) ; + while ( $i < $total_ram_in_MB / 1.7 ) + { + $a .= "A" x 1000_000; + myprintf( "$i " ) ; + $i++ ; + } ; + myprintf( "\nStress memory consumption after: %.1f MiB of %.1f MiB\n", memory_consumption_of_myself( ) / $KIBI / $KIBI, $total_ram_in_MB ) ; + return ; +} + +sub tests_memory_consumption_of_myself +{ + note( 'Entering tests_memory_consumption_of_myself()' ) ; + + note( "memory_consumption_of_myself: " . memory_consumption_of_myself( ) . " bytes aka " . bytes_display_string_dec( memory_consumption_of_myself( ) ) ) ; + like( memory_consumption_of_myself( ), qr{\d+}xms,'tests_memory_consumption_of_myself no args') ; + like( memory_consumption_of_myself( 1 ), qr{\d+}xms,'tests_memory_consumption_of_myself 1') ; + like( memory_consumption_of_myself( $PROCESS_ID ), qr{\d+}xms,"tests_memory_consumption_of_myself $PROCESS_ID") ; + + + note( 'Leaving tests_memory_consumption_of_myself()' ) ; + return ; +} + +sub memory_consumption_of_myself +{ + # memory consumed by imapsync until now in bytes + return( ( memory_consumption_of_pids( ) )[0] ); +} + +sub debugmemory +{ + my $mysync = shift @ARG ; + if ( ! $mysync->{ debugmemory } ) { return q{} ; } + + my $precision = shift @ARG ; + return( mysprintf( "Memory consumption$precision: %.1f MiB\n", memory_consumption_of_myself( ) / $KIBI / $KIBI ) ) ; +} + +sub memory_consumption_of_pids +{ + my @pid = @ARG ; + # No pid in ARG means find myself memory + @pid = ( @pid ) ? @pid : ( $PROCESS_ID ) ; + + #$sync->{ debug } and myprint( "memory_consumption_of_pids PIDs: @pid\n" ) ; + my @val ; + if ( ( 'MSWin32' eq $OSNAME ) or ( 'cygwin' eq $OSNAME ) ) + { + @val = memory_consumption_of_pids_win32( @pid ) ; + } + else + { + # Unix, Mac OS X included + @val = memory_consumption_of_pids_unix( @pid ) ; + } + return( @val ) ; +} + + +sub memory_consumption_of_pids_unix +{ + my @pid = @_ ; + # Use IPC::Open3 from perlcrit -3 + # But it stalls on Darwin, I don't understand why! + #my @ps = backtick( "ps -o rss -p @pid" ) ; + #myprint( "ps: @ps" ) ; + my @ps = qx{ ps -o rss -p @pid } ; + shift @ps ; # First line is the column name "RSS" + chomp @ps ; + # convert to octets + my @val = map { $_ * $KIBI } @ps ; + return( @val ) ; +} + + +sub tests_memory_consumption_of_all_pids +{ + note( 'Entering tests_memory_consumption_of_all_pids()' ) ; + + note( "memory_consumption_of_all_pids: " . memory_consumption_of_all_pids( ) . " bytes aka " . bytes_display_string_dec( memory_consumption_of_all_pids( ) ) ) ; + like( memory_consumption_of_all_pids( ), qr{\d+}xms, 'tests_memory_consumption_of_all_pids no args') ; + + note( 'Leaving tests_memory_consumption_of_all_pids()' ) ; + return ; +} + + +sub memory_consumption_of_all_pids +{ + my @all_pids = all_pids( ) ; + my @memory_consumption_of_all_pids = memory_consumption_of_pids( @all_pids ) ; + my $memory_consumption_of_all_pids = add( @memory_consumption_of_all_pids ) ; + return $memory_consumption_of_all_pids ; +} + + +sub tests_all_pids +{ + note( 'Entering tests_all_pids()' ) ; + + note( 'all_pids', join( ' ', all_pids( ) ) ) ; + ok( all_pids( ), 'tests_all_pids: no args => list of pids' ) ; + + + note( 'Leaving tests_all_pids()' ) ; + return ; +} + + +sub all_pids +{ + my @all_pids ; + if ( ( 'MSWin32' eq $OSNAME ) or ( 'cygwin' eq $OSNAME ) ) { + @all_pids = all_pids_win32( ) ; + } + else + { + # Unix + @all_pids = all_pids_unix( ) ; + } + return( @all_pids ) ; +} + +sub all_pids_unix +{ + my @ps = qx{ ps -e -o pid } ; + shift @ps ; # First line is the column name "PID" + chomp @ps ; + return @ps ; +} + + + +sub tests_memory_consumption_of_pids_win32 +{ + note( 'Entering tests_memory_consumption_of_pids_win32()' ) ; + + note( memory_consumption_of_pids_win32( $PROCESS_ID ) ) ; + #ok( memory_consumption_of_pids_win32( $PROCESS_ID ), 'tests_memory_consumption_of_pids_win32: no args => ' ) ; + + note( 'Leaving tests_memory_consumption_of_pids_win32()' ) ; + return ; +} + + +sub memory_consumption_of_pids_win32 +{ + # Windows + my @PID = @_; + my %PID; + # hash of pids as key values + map { $PID{$_}++ } @PID; + + # Does not work but should work reading the tasklist documentation + #@ps = qx{ tasklist /FI "PID eq @PID" }; + + my @ps = qx{ tasklist /NH /FO TABLE } ; + #my @ps = backtick( 'tasklist /NH /FO TABLE' ) ; + #myprint( "-" x $STD_CHAR_PER_LINE, "\n", @ps, "-" x $STD_CHAR_PER_LINE, "\n" ) ; + my @val ; + #myprint( @ps ) ; + foreach my $line ( @ps ) { + my( $name, $pid, $mem ) = ( split / +/, $line )[ 0, 1, 4 ] ; + next if (! $pid); + #myprint( "[$name][$pid][$mem]\n" ) ; + $pid = remove_qq( $pid ) ; + if ( $PID{ $pid } ) + { + #myprint( "MATCH $pid\n" ) ; + chomp $mem ; + $mem = remove_qq( $mem ) ; + $mem = remove_not_num( $mem ) ; + if ( is_number( $mem ) ) + { + #myprint( "[$mem] ", $mem * $KIBI, "\n" ) ; + push @val, $mem * $KIBI ; + } + } + } + return( @val ) ; +} + + + +sub all_pids_win32 +{ + my @ps = qx{ tasklist /NH /FO CSV } ; + my @pids ; + foreach my $line ( @ps ) + { + my( $name, $pid, $mem ) = ( split ',', $line )[ 0, 1, 4 ] ; + next if ( ! $pid ) ; + #myprint( "[$name][$pid][$mem]\n" ) ; + $pid = remove_qq( $pid ) ; + push @pids, $pid ; + } + return( @pids ) ; +} + + + +sub tests_memory_consumption_all_pids_percent +{ + note( 'Entering tests_memory_consumption_all_pids_percent()' ) ; + + note( memory_consumption_all_pids_percent( ) . " (%)" ) ; + like( memory_consumption_all_pids_percent( ), qr{^0|^(\d+\.\d+)$}xms, 'tests_memory_consumption_all_pids_percent: no args => like 12.34' ) ; + + ok( 0 <= memory_consumption_all_pids_percent( ), 'tests_memory_consumption_all_pids_percent: > 0' ) ; + ok( 100 >= memory_consumption_all_pids_percent( ), 'tests_memory_consumption_all_pids_percent: <= 100' ) ; + note( 'Leaving tests_memory_consumption_all_pids_percent()' ) ; + + return ; +} + + + +sub memory_consumption_all_pids_percent +{ + my $percent ; + + my $memory_consumption_of_all_pids = memory_consumption_of_all_pids( ) ; + my $total_memory_bytes = total_ram_memory_bytes( ) || return 0 ; + + $percent = sprintf( "%.2f", 100 * $memory_consumption_of_all_pids / $total_memory_bytes ) ; + return $percent ; +} + + + +sub tests_memory_consumption_all_pids_percent_Proc_ProcessTable +{ + note( 'Entering tests_memory_consumption_all_pids_percent_Proc_ProcessTable()' ) ; + require_ok( 'Proc::ProcessTable' ) ; + + note( memory_consumption_all_pids_percent_Proc_ProcessTable( ) . " (%)" ) ; + like( memory_consumption_all_pids_percent_Proc_ProcessTable( ), qr{^0|^(\d+\.\d+)$}xms, 'tests_memory_consumption_all_pids_percent_Proc_ProcessTable: no args => like 12.34' ) ; + + my $mysync = { } ; + + like( memory_consumption_all_pids_percent_Proc_ProcessTable( $mysync ), qr{^0|^(\d+\.\d+)$}xms, 'tests_memory_consumption_all_pids_percent_Proc_ProcessTable: { } => like 12.34' ) ; + note( 'Leaving tests_memory_consumption_all_pids_percent_Proc_ProcessTable()' ) ; + + return ; +} + +# Proc::ProcessTable pctmem does NOT work for Win32 Darwin +# Negative values and negative zeros for Darwin +# zeros for Win32 +# +sub memory_consumption_all_pids_percent_Proc_ProcessTable +{ + my $mysync = shift @ARG ; + + my $percent ; + if ( eval { require Proc::ProcessTable } ) + { + my $table_all_processes = Proc::ProcessTable->new( ) ; + + if ( pctmem_available( $table_all_processes ) ) + { + #pctmem is memory percentage of a process + foreach my $process ( @{ $table_all_processes->table( ) } ) + { + #myprint( "pctmem: ", $process->pctmem( ), "\n" ) ; + # + $percent += max( 0, $process->pctmem( ) ) ; + } + } + else + { + $percent = 0 ; + } + } + else + { + $percent = 0 ; + } + + $percent = sprintf( "%.2f", $percent ) ; + + return $percent ; +} + + +sub tests_pctmem_available +{ + note( 'Entering tests_pctmem_available()' ) ; + + is( undef, pctmem_available( ), 'pctmem_available: no args => undef' ) ; + + SKIP: { + skip( 'no Proc::ProcessTable', 1 ) if ( ! eval { require Proc::ProcessTable } ) ; + my $table_all_processes = Proc::ProcessTable->new( ) ; + like( pctmem_available( $table_all_processes ), qr{^(0|1)$}xms, 'pctmem_available: => 0 or 1' ) ; + } + + note( 'Leaving tests_pctmem_available()' ) ; + return ; +} + + +sub pctmem_available +{ + my $table_all_processes = shift @ARG ; + + if ( ! defined $table_all_processes ) { return ; } ; + + my @fields = $table_all_processes->fields( ) ; + + my %fields = map { defined( $_ ) ? ( $_ => 1 ) : ( ) } @fields ; + + if ( exists( $fields{ pctmem } ) ) + { + return 1 ; + } + else + { + return 0 ; + } + + return ; +} + +sub tests_backtick +{ + note( 'Entering tests_backtick()' ) ; + + is( undef, backtick( ), 'backtick: no args' ) ; + is( undef, backtick( q{} ), 'backtick: empty command' ) ; + + SKIP: { + skip( 'test for MSWin32', 5 ) if ('MSWin32' ne $OSNAME) ; + my @output ; + @output = backtick( 'echo Hello World!' ) ; + # Add \r on Windows. + ok( "Hello World!\r\n" eq $output[0], 'backtick: echo Hello World!' ) ; + $sync->{ debug } and myprint( "[@output]" ) ; + @output = backtick( 'echo Hello & echo World!' ) ; + ok( "Hello \r\n" eq $output[0], 'backtick: echo Hello & echo World! line 1' ) ; + ok( "World!\r\n" eq $output[1], 'backtick: echo Hello & echo World! line 2' ) ; + $sync->{ debug } and myprint( "[@output][$output[0]][$output[1]]" ) ; + # Scalar context + ok( "Hello World!\r\n" eq backtick( 'echo Hello World!' ), + 'backtick: echo Hello World! scalar' ) ; + ok( "Hello \r\nWorld!\r\n" eq backtick( 'echo Hello & echo World!' ), + 'backtick: echo Hello & echo World! scalar 2 lines' ) ; + } ; + SKIP: { + skip( 'test for Unix', 7 ) if ('MSWin32' eq $OSNAME) ; + is( undef, backtick( 'aaaarrrg' ), 'backtick: aaaarrrg command not found' ) ; + # Array context + my @output ; + @output = backtick( 'echo Hello World!' ) ; + ok( "Hello World!\n" eq $output[0], 'backtick: echo Hello World!' ) ; + $sync->{ debug } and myprint( "[@output]" ) ; + @output = backtick( "echo Hello\necho World!" ) ; + ok( "Hello\n" eq $output[0], 'backtick: echo Hello; echo World! line 1' ) ; + ok( "World!\n" eq $output[1], 'backtick: echo Hello; echo World! line 2' ) ; + $sync->{ debug } and myprint( "[@output]" ) ; + # Scalar context + ok( "Hello World!\n" eq backtick( 'echo Hello World!' ), + 'backtick: echo Hello World! scalar' ) ; + ok( "Hello\nWorld!\n" eq backtick( "echo Hello\necho World!" ), + 'backtick: echo Hello; echo World! scalar 2 lines' ) ; + # Return error positive value, that's ok + is( undef, backtick( 'false' ), 'backtick: false returns no output' ) ; + my $mem = backtick( "ps -o vsz -p $PROCESS_ID" ) ; + $sync->{ debug } and myprint( "MEM=$mem\n" ) ; + + } + + note( 'Leaving tests_backtick()' ) ; + return ; +} + + +sub backtick +{ + my $command = shift @ARG ; + + if ( ! $command ) { return ; } + + my ( $writer, $reader, $err ) ; + my @output ; + my $pid ; + my $eval = eval { + $pid = IPC::Open3::open3( $writer, $reader, $err, $command ) ; + } ; + if ( $EVAL_ERROR ) { + myprint( $EVAL_ERROR ) ; + return ; + } + if ( ! $eval ) { return ; } + if ( ! $pid ) { return ; } + waitpid( $pid, 0 ) ; + @output = <$reader>; # Output here + # + #my @errors = <$err>; #Errors here, instead of the console + if ( not @output ) { return ; } + #myprint( @output ) ; + + if ( $output[0] =~ /\Qopen3: exec of $command failed\E/mxs ) { return ; } + if ( wantarray ) { + return( @output ) ; + } else { + return( join( q{}, @output) ) ; + } +} + + + +sub tests_check_binary_embed_all_dyn_libs +{ + note( 'Entering tests_check_binary_embed_all_dyn_libs()' ) ; + + is( 1, check_binary_embed_all_dyn_libs( ), 'check_binary_embed_all_dyn_libs: no args => 1' ) ; + + note( 'Leaving tests_check_binary_embed_all_dyn_libs()' ) ; + + return ; +} + + +sub check_binary_embed_all_dyn_libs +{ + my @search_dyn_lib_locale = search_dyn_lib_locale( ) ; + + if ( @search_dyn_lib_locale ) + { + myprint( "Found myself $PROGRAM_NAME pid $PROCESS_ID using locale dynamic libraries that seems out of myself:\n" ) ; + myprint( @search_dyn_lib_locale ) ; + if ( $PROGRAM_NAME =~ m{imapsync_bin_Darwin} ) + { + return 0 ; + } + elsif ( $PROGRAM_NAME =~ m{imapsync.*\.exe} ) + { + return 0 ; + } + else + { + # is always ok for non binary + return 1 ; + } + } + else + { + # Found only embedded dynamic lib + myprint( "Found only embedded dynamic lib. Good!\n" ) ; + return 1 ; + } +} + +sub search_dyn_lib_locale +{ + if ( 'darwin' eq $OSNAME ) + { + return search_dyn_lib_locale_darwin( ) ; + } + if ( 'linux' eq $OSNAME ) + { + return search_dyn_lib_locale_linux( ) ; + } + if ( 'MSWin32' eq $OSNAME ) + { + return search_dyn_lib_locale_MSWin32( ) ; + } + +} + +sub search_dyn_lib_locale_darwin +{ + my $command = qq{ lsof -p $PROCESS_ID | grep ' REG ' | grep .dylib | grep -v '/par-' } ; + myprint( "Search non embeded dynamic libs with the command: $command\n" ) ; + return backtick( $command ) ; +} + +sub search_dyn_lib_locale_linux +{ + my $command = qq{ lsof -p $PROCESS_ID | grep ' REG ' | grep -v '/tmp/par-' | grep '\.so' } ; + myprint( "Search non embeded dynamic libs with the command: $command\n" ) ; + return backtick( $command ) ; +} + +sub search_dyn_lib_locale_MSWin32 +{ + my $command = qq{ Listdlls.exe $PROCESS_ID|findstr Strawberry } ; + # $command = qq{ Listdlls.exe $PROCESS_ID|findstr Strawberry } ; + myprint( "Search non embeded dynamic libs with the command: $command\n" ) ; + return qx( $command ) ; +} + + + +sub remove_not_num +{ + + my $string = shift @ARG ; + $string =~ tr/0-9//cd ; + #myprint( "tr [$string]\n" ) ; + return( $string ) ; +} + +sub tests_remove_not_num +{ + note( 'Entering tests_remove_not_num()' ) ; + + is( '123', remove_not_num( 123 ), 'remove_not_num( 123 )' ) ; + is( '123', remove_not_num( '123' ), q{remove_not_num( '123' )} ) ; + is( '123', remove_not_num( '12 3' ), q{remove_not_num( '12 3' )} ) ; + is( '123', remove_not_num( 'a 12 3 Ko' ), q{remove_not_num( 'a 12 3 Ko' )} ) ; + is( '123', remove_not_num( 'a 12 3 K' ), q{remove_not_num( 'a 12 3 K' )} ) ; + is( '123', remove_not_num( 'a 12,3 K' ), q{remove_not_num( 'a 12, 3 K' )} ) ; + is( '173892', remove_not_num( 'a 173,892 K' ), q{remove_not_num( 'a 173,892 K' )} ) ; + + note( 'Leaving tests_remove_not_num()' ) ; + return ; +} + + + + +sub tests_remove_qq +{ + note( 'Entering tests_remove_qq()' ) ; + + is( undef, remove_qq( ), 'tests_remove_qq: no args => undef' ) ; + is( '', remove_qq( '' ), 'tests_remove_qq: empty => empty' ) ; + is( 'ABC', remove_qq( 'ABC' ), 'tests_remove_qq: ABC => ABC' ) ; + is( 'ABC', remove_qq( '"ABC"' ), 'tests_remove_qq: "ABC" => ABC' ) ; + is( '"ABC', remove_qq( '""ABC"' ), 'tests_remove_qq: ""ABC" => "ABC' ) ; + is( 'ABC"', remove_qq( '"ABC""' ), 'tests_remove_qq: "ABC"" => ABC"' ) ; + is( '"ABC"', remove_qq( '""ABC""' ), 'tests_remove_qq: ""ABC"" => "ABC"' ) ; + + note( 'Leaving tests_remove_qq()' ) ; + return ; +} + + +sub remove_qq +{ + my $string = shift ; + + if ( ! defined $string ) { return ; } + + #myprint( "$string\n" ) ; + + if ( $string =~ /^"(.*)"$/xo ) + { + return( $1 ) ; + }else{ + return( $string ) ; + } +} + + +sub date_from_rcs +{ + my $d = shift @ARG ; + + my %num2mon = qw( 01 Jan 02 Feb 03 Mar 04 Apr 05 May 06 Jun 07 Jul 08 Aug 09 Sep 10 Oct 11 Nov 12 Dec ) ; + if ($d =~ m{(\d{4})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) { + # Handles the following format + # 2015/07/10 11:05:59 -- Generated by RCS Date tag. + #myprint( "$d\n" ) ; + #myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ; + my ($year, $month, $day, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6) ; + $month = $num2mon{$month} ; + $d = "$day-$month-$year $hour:$min:$sec +0000" ; + #myprint( "$d\n" ) ; + } + return( $d ) ; +} + +sub tests_date_from_rcs +{ + note( 'Entering tests_date_from_rcs()' ) ; + + ok('19-Sep-2015 16:11:07 +0000' + eq date_from_rcs('Date: 2015/09/19 16:11:07 '), 'date_from_rcs from RCS date' ) ; + + note( 'Leaving tests_date_from_rcs()' ) ; + return ; +} + +sub good_date +{ + # two incoming formats: + # header Tue, 24 Aug 2010 16:00:00 +0200 + # internal 24-Aug-2010 16:00:00 +0200 + + # outgoing format: internal date format + # 24-Aug-2010 16:00:00 +0200 + + my $d = shift @ARG ; + return(q{}) if not defined $d; + + SWITCH: { + if ( $d =~ m{(\d?)(\d-...-\d{4})(\s\d{2}:\d{2}:\d{2})(\s(?:\+|-)\d{4})?}xo ) { + #myprint( "internal: [$1][$2][$3][$4]\n" ) ; + my ($day_1, $date_rest, $hour, $zone) = ($1,$2,$3,$4) ; + $day_1 = '0' if ($day_1 eq q{}) ; + $zone = ' +0000' if not defined $zone ; + $d = $day_1 . $date_rest . $hour . $zone ; + last SWITCH ; + } + + if ($d =~ m{(?:\w{3,},\s)?(\d{1,2}),?\s+(\w{3,})\s+(\d{2,4})\s+(\d{1,2})(?::|\.)(\d{1,2})(?:(?::|\.)(\d{1,2}))?\s*((?:\+|-)\d{4})?}xo ) { + # Handles any combination of following formats + # Tue, 24 Aug 2010 16:00:00 +0200 -- Standard + # 24 Aug 2010 16:00:00 +0200 -- Missing Day of Week + # Tue, 24 Aug 97 16:00:00 +0200 -- Two digit year + # Tue, 24 Aug 1997 16.00.00 +0200 -- Periods instead of colons + # Tue, 24 Aug 1997 16:00:00 +0200 -- Extra whitespace between year and hour + # Tue, 24 Aug 1997 6:5:2 +0200 -- Single digit hour, min, or second + # Tue, 24, Aug 1997 16:00:00 +0200 -- Extra comma + + #myprint( "header: [$1][$2][$3][$4][$5][$6][$7][$8]\n" ) ; + my ($day, $month, $year, $hour, $min, $sec, $zone) = ($1,$2,$3,$4,$5,$6,$7,$8); + $year = '19' . $year if length($year) == 2 && $year =~ m/^[789]/xo; + $year = '20' . $year if length($year) == 2; + + $month = substr $month, 0, 3 if length($month) > 4; + $day = mysprintf( '%02d', $day); + $hour = mysprintf( '%02d', $hour); + $min = mysprintf( '%02d', $min); + $sec = '00' if not defined $sec ; + $sec = mysprintf( '%02d', $sec ) ; + $zone = '+0000' if not defined $zone ; + $d = "$day-$month-$year $hour:$min:$sec $zone" ; + last SWITCH ; + } + + if ($d =~ m{(?:.{3})\s(...)\s+(\d{1,2})\s(\d{1,2}):(\d{1,2}):(\d{1,2})\s(?:\w{3})?\s?(\d{4})}xo ) { + # Handles any combination of following formats + # Sun Aug 20 11:55:09 2006 + # Wed Jan 24 11:58:38 MST 2007 + # Wed Jan 2 08:40:57 2008 + + #myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ; + my ($month, $day, $hour, $min, $sec, $year) = ($1,$2,$3,$4,$5,$6); + $day = mysprintf( '%02d', $day ) ; + $hour = mysprintf( '%02d', $hour ) ; + $min = mysprintf( '%02d', $min ) ; + $sec = mysprintf( '%02d', $sec ) ; + $d = "$day-$month-$year $hour:$min:$sec +0000" ; + last SWITCH ; + } + my %num2mon = qw( 01 Jan 02 Feb 03 Mar 04 Apr 05 May 06 Jun 07 Jul 08 Aug 09 Sep 10 Oct 11 Nov 12 Dec ) ; + + if ($d =~ m{(\d{4})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) { + # Handles the following format + # 2015/07/10 11:05:59 -- Generated by RCS Date tag. + #myprint( "$d\n" ) ; + #myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ; + my ($year, $month, $day, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6) ; + $month = $num2mon{$month} ; + $d = "$day-$month-$year $hour:$min:$sec +0000" ; + #myprint( "$d\n" ) ; + last SWITCH ; + } + + if ($d =~ m{(\d{2})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) { + # Handles the following format + # 02/06/09 22:18:08 -- Generated by AVTECH TemPageR devices + + #myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ; + my ($month, $day, $year, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6); + $year = '20' . $year; + $month = $num2mon{$month}; + $d = "$day-$month-$year $hour:$min:$sec +0000"; + last SWITCH ; + } + + if ($d =~ m{\w{6,},\s(\w{3})\w+\s+(\d{1,2}),\s(\d{4})\s(\d{2}):(\d{2})\s(AM|PM)}xo ) { + # Handles the following format + # Saturday, December 14, 2002 05:00 PM - KBtoys.com order confirmations + + my ($month, $day, $year, $hour, $min, $apm) = ($1,$2,$3,$4,$5,$6); + + $hour += 12 if $apm eq 'PM' ; + $day = mysprintf( '%02d', $day ) ; + $d = "$day-$month-$year $hour:$min:00 +0000" ; + last SWITCH ; + } + + if ($d =~ m{(\w{3})\s(\d{1,2})\s(\d{4})\s(\d{2}):(\d{2}):(\d{2})\s((?:\+|-)\d{4})}xo ) { + # Handles the following format + # Saturday, December 14, 2002 05:00 PM - jr.com order confirmations + + my ($month, $day, $year, $hour, $min, $sec, $zone) = ($1,$2,$3,$4,$5,$6,$7); + + $day = mysprintf( '%02d', $day ) ; + $d = "$day-$month-$year $hour:$min:$sec $zone"; + last SWITCH ; + } + + if ($d =~ m{(\d{1,2})-(\w{3})-(\d{4})}xo ) { + # Handles the following format + # 21-Jun-2001 - register.com domain transfer email circa 2001 + + my ($day, $month, $year) = ($1,$2,$3); + $day = mysprintf( '%02d', $day); + $d = "$day-$month-$year 11:11:11 +0000"; + last SWITCH ; + } + + # unknown or unmatch => return same string + return($d); + } + + $d = qq("$d") ; + return( $d ) ; +} + + +sub tests_good_date +{ + note( 'Entering tests_good_date()' ) ; + + ok(q{} eq good_date(), 'good_date no arg'); + ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('24-Aug-2010 16:00:00 +0200'), 'good_date internal 2digit zone'); + ok('"24-Aug-2010 16:00:00 +0000"' eq good_date('24-Aug-2010 16:00:00'), 'good_date internal 2digit no zone'); + ok('"01-Sep-2010 16:00:00 +0200"' eq good_date( '1-Sep-2010 16:00:00 +0200'), 'good_date internal SP 1digit'); + ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('Tue, 24 Aug 2010 16:00:00 +0200'), 'good_date header 2digit zone'); + ok('"01-Sep-2010 16:00:00 +0000"' eq good_date('Wed, 1 Sep 2010 16:00:00'), 'good_date header SP 1digit zone'); + ok('"01-Sep-2010 16:00:00 +0200"' eq good_date('Wed, 1 Sep 2010 16:00:00 +0200'), 'good_date header SP 1digit zone'); + ok('"01-Sep-2010 16:00:00 +0200"' eq good_date('Wed, 1 Sep 2010 16:00:00 +0200 (CEST)'), 'good_date header SP 1digit zone'); + ok('"06-Feb-2009 22:18:08 +0000"' eq good_date('02/06/09 22:18:08'), 'good_date header TemPageR'); + ok('"02-Jan-2008 08:40:57 +0000"' eq good_date('Wed Jan 2 08:40:57 2008'), 'good_date header dice.com support 1digit day'); + ok('"20-Aug-2006 11:55:09 +0000"' eq good_date('Sun Aug 20 11:55:09 2006'), 'good_date header dice.com support 2digit day'); + ok('"24-Jan-2007 11:58:38 +0000"' eq good_date('Wed Jan 24 11:58:38 MST 2007'), 'good_date header status-now.com'); + ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('24 Aug 2010 16:00:00 +0200'), 'good_date header missing date of week'); + ok('"24-Aug-2067 16:00:00 +0200"' eq good_date('Tue, 24 Aug 67 16:00:00 +0200'), 'good_date header 2digit year'); + ok('"24-Aug-1977 16:00:00 +0200"' eq good_date('Tue, 24 Aug 77 16:00:00 +0200'), 'good_date header 2digit year'); + ok('"24-Aug-1987 16:00:00 +0200"' eq good_date('Tue, 24 Aug 87 16:00:00 +0200'), 'good_date header 2digit year'); + ok('"24-Aug-1997 16:00:00 +0200"' eq good_date('Tue, 24 Aug 97 16:00:00 +0200'), 'good_date header 2digit year'); + ok('"24-Aug-2004 16:00:00 +0200"' eq good_date('Tue, 24 Aug 04 16:00:00 +0200'), 'good_date header 2digit year'); + ok('"24-Aug-1997 16:00:00 +0200"' eq good_date('Tue, 24 Aug 1997 16.00.00 +0200'), 'good_date header period time sep'); + ok('"24-Aug-1997 16:00:00 +0200"' eq good_date('Tue, 24 Aug 1997 16:00:00 +0200'), 'good_date header extra white space type1'); + ok('"24-Aug-1997 05:06:02 +0200"' eq good_date('Tue, 24 Aug 1997 5:6:2 +0200'), 'good_date header 1digit time vals'); + ok('"24-Aug-1997 05:06:02 +0200"' eq good_date('Tue, 24, Aug 1997 05:06:02 +0200'), 'good_date header extra commas'); + ok('"01-Oct-2003 12:45:24 +0000"' eq good_date('Wednesday, 01 October 2003 12:45:24 CDT'), 'good_date header no abbrev'); + ok('"11-Jan-2005 17:58:27 -0500"' eq good_date('Tue, 11 Jan 2005 17:58:27 -0500'), 'good_date extra white space'); + ok('"18-Dec-2002 15:07:00 +0000"' eq good_date('Wednesday, December 18, 2002 03:07 PM'), 'good_date kbtoys.com orders'); + ok('"16-Dec-2004 02:01:49 -0500"' eq good_date('Dec 16 2004 02:01:49 -0500'), 'good_date jr.com orders'); + ok('"21-Jun-2001 11:11:11 +0000"' eq good_date('21-Jun-2001'), 'good_date register.com domain transfer'); + ok('"18-Nov-2012 18:34:38 +0100"' eq good_date('Sun, 18 Nov 2012 18:34:38 +0100'), 'good_date pop2imap bug (Westeuropäische Normalzeit)'); + ok('"19-Sep-2015 16:11:07 +0000"' eq good_date('Date: 2015/09/19 16:11:07 '), 'good_date from RCS date' ) ; + + note( 'Leaving tests_good_date()' ) ; + return ; +} + + +sub tests_list_keys_in_2_not_in_1 +{ + note( 'Entering tests_list_keys_in_2_not_in_1()' ) ; + + + my @list; + ok( ! list_keys_in_2_not_in_1( {}, {}), 'list_keys_in_2_not_in_1: {} {}'); + ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {}, {} ) ] ), 'list_keys_in_2_not_in_1: {} {}'); + ok( 0 == compare_lists( ['a','b'], [ list_keys_in_2_not_in_1( {}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {} {a, b}'); + ok( 0 == compare_lists( ['b'], [ list_keys_in_2_not_in_1( {'a' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a} {a, b}'); + ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {'a' => 1, 'b' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b} {a, b}'); + ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {'a' => 1, 'b' => 1, 'c' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b, c} {a, b}'); + ok( 0 == compare_lists( ['b'], [ list_keys_in_2_not_in_1( {'a' => 1, 'c' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b, c} {a, b}'); + + note( 'Leaving tests_list_keys_in_2_not_in_1()' ) ; + return ; +} + +sub list_keys_in_2_not_in_1 +{ + my $hash_1_ref = shift; + my $hash_2_ref = shift; + my @list; + + foreach my $key ( sort keys %{ $hash_2_ref } ) { + #$sync->{ debug } and print "$key\n" ; + if ( exists $hash_1_ref->{$key} ) + { + next ; + } + #$sync->{ debug } and print "list_keys_in_2_not_in_1: $key\n" ; + push @list, $key ; + } + #$sync->{ debug } and print "@list\n" ; + return( @list ) ; +} + + +sub list_folders_in_2_not_in_1 +{ + + my ( @h2_folders_not_in_h1, %h2_folders_not_in_h1 ) ; + @h2_folders_not_in_h1 = list_keys_in_2_not_in_1( \%h1_folders_all, \%h2_folders_all ) ; + map { $h2_folders_not_in_h1{$_} = 1} @h2_folders_not_in_h1 ; + @h2_folders_not_in_h1 = list_keys_in_2_not_in_1( \%h2_folders_from_1_all, \%h2_folders_not_in_h1 ) ; + #$sync->{ debug } and print "h2_folders_not_in_h1: @h2_folders_not_in_h1\n" ; + return( reverse @h2_folders_not_in_h1 ) ; +} + +sub tests_nb_messages_in_2_not_in_1 +{ + note( 'Entering tests_stats_across_folders()' ) ; + is( undef, nb_messages_in_2_not_in_1( ), 'nb_messages_in_2_not_in_1: no args => undef' ) ; + + my $mysync->{ h1_folders_of_md5 }->{ 'some_id_01' }->{ 'some_folder_01' } = 1 ; + is( 0, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: no messages in 2 => 0' ) ; + + $mysync->{ h1_folders_of_md5 }->{ 'some_id_in_1_and_2' }->{ 'some_folder_01' } = 2 ; + $mysync->{ h2_folders_of_md5 }->{ 'some_id_in_1_and_2' }->{ 'some_folder_02' } = 4 ; + + is( 0, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: a common message => 0' ) ; + + $mysync->{ h2_folders_of_md5 }->{ 'some_id_in_2_not_in_1' }->{ 'some_folder_02' } = 1 ; + is( 1, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: one message in_2_not_in_1 => 1' ) ; + + $mysync->{ h2_folders_of_md5 }->{ 'some_other_id_in_2_not_in_1' }->{ 'some_folder_02' } = 3 ; + is( 2, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: two messages in_2_not_in_1 => 2' ) ; + + note( 'Leaving tests_stats_across_folders()' ) ; + return ; +} + +sub nb_messages_in_2_not_in_1 +{ + my $mysync = shift @ARG ; + if ( not defined $mysync ) { return ; } + + $mysync->{ nb_messages_in_2_not_in_1 } = scalar( + list_keys_in_2_not_in_1( + $mysync->{ h1_folders_of_md5 }, + $mysync->{ h2_folders_of_md5 } ) ) ; + + return $mysync->{ nb_messages_in_2_not_in_1 } ; +} + + +sub nb_messages_in_1_not_in_2 +{ + my $mysync = shift @ARG ; + if ( not defined $mysync ) { return ; } + + $mysync->{ nb_messages_in_1_not_in_2 } = scalar( + list_keys_in_2_not_in_1( + $mysync->{ h2_folders_of_md5 }, + $mysync->{ h1_folders_of_md5 } ) ) ; + + return $mysync->{ nb_messages_in_1_not_in_2 } ; +} + + + +sub comment_on_final_diff_in_1_not_in_2 +{ + my $mysync = shift @ARG ; + + if ( not defined $mysync + or $mysync->{ justfolders } + or $mysync->{ useuid } + ) + { + return ; + } + + my $nb_identified_h1_messages = scalar( keys %{ $mysync->{ h1_folders_of_md5 } } ) ; + my $nb_identified_h2_messages = scalar( keys %{ $mysync->{ h2_folders_of_md5 } } ) ; + $mysync->{ debug } and myprint( "nb_keys h1_folders_of_md5 $nb_identified_h1_messages\n" ) ; + $mysync->{ debug } and myprint( "nb_keys h2_folders_of_md5 $nb_identified_h2_messages\n" ) ; + + if ( 0 == $nb_identified_h1_messages ) { return ; } + + # Calculate if not yet done + if ( not defined $mysync->{ nb_messages_in_1_not_in_2 } ) + { + nb_messages_in_1_not_in_2( $mysync ) ; + } + + + if ( 0 == $mysync->{ nb_messages_in_1_not_in_2 } ) + { + myprint( "The sync looks good, all ", + $nb_identified_h1_messages, + " identified messages in host1 are on host2.\n" ) ; + } + else + { + myprint( "The sync is not finished, there are ", + $mysync->{ nb_messages_in_1_not_in_2 }, + " among ", + $nb_identified_h1_messages, + " identified messages in host1 that are not on host2.\n" ) ; + } + + + if ( 1 <= $mysync->{ h1_nb_msg_noheader } ) + { + myprint( "There are ", + $mysync->{ h1_nb_msg_noheader }, + " unidentified messages (usually Sent or Draft messages).", + " To sync them add option --addheader\n" ) ; + } + else + { + myprint( "There is no unidentified message on host1.\n" ) ; + } + + return ; +} + +sub comment_on_final_diff_in_2_not_in_1 +{ + my $mysync = shift @ARG ; + + if ( not defined $mysync + or $mysync->{ justfolders } + or $mysync->{ useuid } + ) + { + return ; + } + + my $nb_identified_h2_messages = scalar( keys %{ $mysync->{ h2_folders_of_md5 } } ) ; + # Calculate if not done yet + if ( not defined $mysync->{ nb_messages_in_2_not_in_1 } ) + { + nb_messages_in_2_not_in_1( $mysync ) ; + } + + if ( 0 == $mysync->{ nb_messages_in_2_not_in_1 } ) + { + myprint( "The sync is strict, all ", + $nb_identified_h2_messages, + " identified messages in host2 are on host1.\n" ) ; + } + else + { + myprint( "The sync is not strict, there are ", + $mysync->{ nb_messages_in_2_not_in_1 }, + " among ", + $nb_identified_h2_messages, + " identified messages in host2 that are not on host1.", + " Use --delete2 and sync again to delete them and have a strict sync.\n" + ) ; + } + return ; +} + + +sub tests_match +{ + note( 'Entering tests_match()' ) ; + + # undef serie + is( undef, match( ), 'match: no args => undef' ) ; + is( undef, match( 'lalala' ), 'match: one args => undef' ) ; + + # This one gives 0 under a binary made by pp + # but 1 under "normal" Perl interpreter. So a PAR bug? + #is( 1, match( q{}, q{} ), 'match: q{} =~ q{} => 1' ) ; + + is( 'lalala', match( 'lalala', 'lalala' ), 'match: lalala =~ lalala => lalala' ) ; + is( 'lalala', match( 'lalala', '^lalala' ), 'match: lalala =~ ^lalala => lalala' ) ; + is( 'lalala', match( 'lalala', 'lalala$' ), 'match: lalala =~ lalala$ => lalala' ) ; + is( 'lalala', match( 'lalala', '^lalala$' ), 'match: lalala =~ ^lalala$ => lalala' ) ; + is( '_lalala_', match( '_lalala_', 'lalala' ), 'match: _lalala_ =~ lalala => _lalala_' ) ; + is( 'lalala', match( 'lalala', '.*' ), 'match: lalala =~ .* => lalala' ) ; + is( 'lalala', match( 'lalala', '.' ), 'match: lalala =~ . => lalala' ) ; + is( '/lalala/', match( '/lalala/', '/lalala/' ), 'match: /lalala/ =~ /lalala/ => /lalala/' ) ; + + is( 0, match( 'foo', 's/foo/bar/g' ), 'match: foo =~ s/foo/bar/g => 0' ) ; + is( 's/foo/bar/g', match( 's/foo/bar/g', 's/foo/bar/g' ), 'match: s/foo/bar/g =~ s/foo/bar/g => s/foo/bar/g' ) ; + + + is( 0, match( 'lalala', 'ooo' ), 'match: lalala =~ ooo => 0' ) ; + is( 0, match( 'lalala', 'lal_ala' ), 'match: lalala =~ lal_ala => 0' ) ; + is( 0, match( 'lalala', '\.' ), 'match: lalala =~ \. => 0' ) ; + is( 0, match( 'lalalaX', '^lalala$' ), 'match: lalalaX =~ ^lalala$ => 0' ) ; + is( 0, match( 'lalala', '/lalala/' ), 'match: lalala =~ /lalala/ => 0' ) ; + + is( 'LALALA', match( 'LALALA', '(?i:lalala)' ), 'match: LALALA =~ (?i:lalala) => 1' ) ; + + is( undef, match( 'LALALA', '(?{`ls /`})' ), 'match: LALALA =~ (?{`ls /`}) => undef' ) ; + is( undef, match( 'LALALA', '(?{print "CACA"})' ), 'match: LALALA =~ (?{print "CACA"}) => undef' ) ; + is( undef, match( 'CACA', '(??{print "CACA"})' ), 'match: CACA =~ (??{print "CACA"}) => undef' ) ; + + note( 'Leaving tests_match()' ) ; + + return ; +} + +sub match +{ + my( $var, $regex ) = @ARG ; + + # undef cases + if ( ( ! defined $var ) or ( ! defined $regex ) ) { return ; } + + # normal cases + if ( eval { $var =~ qr{$regex} } ) { + return $var ; + }elsif ( $EVAL_ERROR ) { + myprint( "Fatal regex $regex\n" ) ; + return ; + } else { + return 0 ; + } + return ; +} + + +sub tests_notmatch +{ + note( 'Entering tests_notmatch()' ) ; + + # undef serie + is( undef, notmatch( ), 'notmatch: no args => undef' ) ; + is( undef, notmatch( 'lalala' ), 'notmatch: one args => undef' ) ; + + is( 1, notmatch( 'lalala', '/lalala/' ), 'notmatch: lalala !~ /lalala/ => 1' ) ; + is( 0, notmatch( '/lalala/', '/lalala/' ), 'notmatch: /lalala/ !~ /lalala/ => 0' ) ; + is( 1, notmatch( 'lalala', '/ooo/' ), 'notmatch: lalala !~ /ooo/ => 1' ) ; + + # This one gives 1 under a binary made by pp + # but 0 under "normal" Perl interpreter. So a PAR bug, same in tests_match . + #is( 0, notmatch( q{}, q{} ), 'notmatch: q{} !~ q{} => 0' ) ; + + is( 0, notmatch( 'lalala', 'lalala' ), 'notmatch: lalala !~ lalala => 0' ) ; + is( 0, notmatch( 'lalala', '^lalala' ), 'notmatch: lalala !~ ^lalala => 0' ) ; + is( 0, notmatch( 'lalala', 'lalala$' ), 'notmatch: lalala !~ lalala$ => 0' ) ; + is( 0, notmatch( 'lalala', '^lalala$' ), 'notmatch: lalala !~ ^lalala$ => 0' ) ; + is( 0, notmatch( '_lalala_', 'lalala' ), 'notmatch: _lalala_ !~ lalala => 0' ) ; + is( 0, notmatch( 'lalala', '.*' ), 'notmatch: lalala !~ .* => 0' ) ; + is( 0, notmatch( 'lalala', '.' ), 'notmatch: lalala !~ . => 0' ) ; + + + is( 1, notmatch( 'lalala', 'ooo' ), 'notmatch: does not match regex => 1' ) ; + is( 1, notmatch( 'lalala', 'lal_ala' ), 'notmatch: does not match regex => 1' ) ; + is( 1, notmatch( 'lalala', '\.' ), 'notmatch: matches regex => 0' ) ; + is( 1, notmatch( 'lalalaX', '^lalala$' ), 'notmatch: does not match regex => 1' ) ; + + note( 'Leaving tests_notmatch()' ) ; + + return ; +} + +sub notmatch +{ + my( $var, $regex ) = @ARG ; + + # undef cases + if ( ( ! defined $var ) or ( ! defined $regex ) ) { return ; } + + # normal cases + if ( eval { $var !~ $regex } ) { + return 1 ; + }elsif ( $EVAL_ERROR ) { + myprint( "Fatal regex $regex\n" ) ; + return ; + }else{ + return 0 ; + } + return ; +} + + +sub delete_folders_in_2_not_in_1 +{ + + foreach my $folder ( @h2_folders_not_in_1 ) { + if ( defined $delete2foldersonly and eval "\$folder !~ $delete2foldersonly" ) { + myprint( "Not deleting $folder because of --delete2foldersonly $delete2foldersonly\n" ) ; + next ; + } + if ( defined $delete2foldersbutnot and eval "\$folder =~ $delete2foldersbutnot" ) { + myprint( "Not deleting $folder because of --delete2foldersbutnot $delete2foldersbutnot\n" ) ; + next ; + } + my $res = $sync->{dry} ; # always success in dry mode! + $sync->{imap2}->unsubscribe( $folder ) if ( ! $sync->{dry} ) ; + $res = $sync->{imap2}->delete( $folder ) if ( ! $sync->{dry} ) ; + if ( $res ) { + myprint( "Deleted $folder", "$sync->{dry_message}", "\n" ) ; + }else{ + myprint( "Deleting $folder failed", "\n" ) ; + } + } + return ; +} + +sub delete_folder +{ + my ( $mysync, $imap, $folder, $Side ) = @_ ; + if ( ! $mysync ) { return ; } + if ( ! $imap ) { return ; } + if ( ! $folder ) { return ; } + $Side ||= 'HostX' ; + + my $res = $mysync->{dry} ; # always success in dry mode! + if ( ! $mysync->{dry} ) { + $imap->unsubscribe( $folder ) ; + $res = $imap->delete( $folder ) ; + } + if ( $res ) { + myprint( "$Side deleted $folder", $mysync->{dry_message}, "\n" ) ; + return 1 ; + }else{ + myprint( "$Side deleting $folder failed", "\n" ) ; + return ; + } +} + +sub delete1emptyfolders +{ + my $mysync = shift @ARG ; + if ( ! $mysync ) { return ; } # abort if no parameter + if ( ! $mysync->{delete1emptyfolders} ) { return ; } # abort if --delete1emptyfolders off + my $imap = $mysync->{imap1} ; + if ( ! $imap ) { return ; } # abort if no imap + if ( $imap->IsUnconnected( ) ) { return ; } # abort if disconnected + + my %folders_kept ; + myprint( qq{Host1 deleting empty folders\n} ) ; + foreach my $folder ( reverse sort @{ $mysync->{h1_folders_wanted} } ) { + my $parenthood = $imap->is_parent( $folder ) ; + if ( defined $parenthood and $parenthood ) { + myprint( "Host1: folder $folder has subfolders\n" ) ; + $folders_kept{ $folder }++ ; + next ; + } + my $nb_messages_select = examine_folder_and_count( $mysync, $imap, $folder, 'Host1' ) ; + if ( ! defined $nb_messages_select ) { next ; } # Select failed => Neither continue nor keep this folder } + my $nb_messages_search = scalar( @{ $imap->messages( ) } ) ; + if ( 0 != $nb_messages_select and 0 != $nb_messages_search ) { + myprint( "Host1: folder $folder has messages: $nb_messages_search (search) $nb_messages_select (select)\n" ) ; + $folders_kept{ $folder }++ ; + next ; + } + if ( 0 != $nb_messages_select + $nb_messages_search ) { + myprint( "Host1: folder $folder odd messages count: $nb_messages_search (search) $nb_messages_select (select)\n" ) ; + $folders_kept{ $folder }++ ; + next ; + } + # Here we must have 0 messages by messages() aka "SEARCH ALL" and also "EXAMINE" + if ( uc $folder eq 'INBOX' ) { + myprint( "Host1: Not deleting $folder\n" ) ; + $folders_kept{ $folder }++ ; + next ; + } + myprint( "Host1: deleting empty folder $folder\n" ) ; + # can not delete a SELECTed or EXAMINEd folder so closing it + # could changed be SELECT INBOX + $imap->close( ) ; # close after examine does not expunge; anyway expunging an empty folder... + if ( delete_folder( $mysync, $imap, $folder, 'Host1' ) ) { + next ; # Deleted, good! + }else{ + $folders_kept{ $folder }++ ; + next ; # Not deleted, bad! + } + } + remove_deleted_folders_from_wanted_list( $mysync, %folders_kept ) ; + myprint( qq{Host1 ended deleting empty folders\n} ) ; + return ; +} + +sub remove_deleted_folders_from_wanted_list +{ + my ( $mysync, %folders_kept ) = @ARG ; + + my @h1_folders_wanted_init = @{ $mysync->{h1_folders_wanted} } ; + my @h1_folders_wanted_last ; + foreach my $folder ( @h1_folders_wanted_init ) { + if ( $folders_kept{ $folder } ) { + push @h1_folders_wanted_last, $folder ; + } + } + @{ $mysync->{h1_folders_wanted} } = @h1_folders_wanted_last ; + return ; +} + + +sub examine_folder_and_count +{ + my ( $mysync, $imap, $folder, $Side ) = @_ ; + $Side ||= 'HostX' ; + + if ( ! examine_folder( $mysync, $imap, $folder, $Side ) ) { + return ; + } + my $nb_messages_select = count_from_select( $imap->History ) ; + return $nb_messages_select ; +} + + +sub tests_delete1emptyfolders +{ + note( 'Entering tests_delete1emptyfolders()' ) ; + + + is( undef, delete1emptyfolders( ), q{delete1emptyfolders: undef} ) ; + my $syncT ; + is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: undef 2} ) ; + my $imapT ; + $syncT->{imap1} = $imapT ; + is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: undef imap} ) ; + + require_ok( "Test::MockObject" ) ; + $imapT = Test::MockObject->new( ) ; + $syncT->{imap1} = $imapT ; + + $imapT->set_true( 'IsUnconnected' ) ; + is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: Unconnected imap} ) ; + + # Now connected tests + $imapT->set_false( 'IsUnconnected' ) ; + $imapT->mock( 'LastError', sub { q{LastError mocked} } ) ; + + $syncT->{delete1emptyfolders} = 0 ; + tests_delete1emptyfolders_unit( + $syncT, + [ qw{ INBOX DELME1 DELME2 } ], + [ qw{ INBOX DELME1 DELME2 } ], + q{tests_delete1emptyfolders: --delete1emptyfolders OFF} + ) ; + + # All are parents => no deletion at all + $imapT->set_true( 'is_parent' ) ; + $syncT->{delete1emptyfolders} = 1 ; + tests_delete1emptyfolders_unit( + $syncT, + [ qw{ INBOX DELME1 DELME2 } ], + [ qw{ INBOX DELME1 DELME2 } ], + q{tests_delete1emptyfolders: --delete1emptyfolders ON} + ) ; + + # No parents but examine false for all => skip all + $imapT->set_false( 'is_parent', 'examine' ) ; + + tests_delete1emptyfolders_unit( + $syncT, + [ qw{ INBOX DELME1 DELME2 } ], + [ ], + q{tests_delete1emptyfolders: EXAMINE fails} + ) ; + + # examine ok for all but History bad => skip all + $imapT->set_true( 'examine' ) ; + $imapT->mock( 'History', sub { ( q{History badly mocked} ) } ) ; + tests_delete1emptyfolders_unit( + $syncT, + [ qw{ INBOX DELME1 DELME2 } ], + [ ], + q{tests_delete1emptyfolders: examine ok but History badly mocked so count messages fails} + ) ; + + # History good but some messages EXISTS == messages() => no deletion + $imapT->mock( 'History', sub { ( q{* 2 EXISTS} ) } ) ; + $imapT->mock( 'messages', sub { [ qw{ UID_1 UID_2 } ] } ) ; + tests_delete1emptyfolders_unit( + $syncT, + [ qw{ INBOX DELME1 DELME2 } ], + [ qw{ INBOX DELME1 DELME2 } ], + q{tests_delete1emptyfolders: History EXAMINE ok, several messages} + ) ; + + # 0 EXISTS but != messages() => no deletion + $imapT->mock( 'History', sub { ( q{* 0 EXISTS} ) } ) ; + $imapT->mock( 'messages', sub { [ qw{ UID_1 UID_2 } ] } ) ; + tests_delete1emptyfolders_unit( + $syncT, + [ qw{ INBOX DELME1 DELME2 } ], + [ qw{ INBOX DELME1 DELME2 } ], + q{tests_delete1emptyfolders: 0 EXISTS but 2 by messages()} + ) ; + + # 1 EXISTS but != 0 == messages() => no deletion + $imapT->mock( 'History', sub { ( q{* 1 EXISTS} ) } ) ; + $imapT->mock( 'messages', sub { [ ] } ) ; + tests_delete1emptyfolders_unit( + $syncT, + [ qw{ INBOX DELME1 DELME2 } ], + [ qw{ INBOX DELME1 DELME2 } ], + q{tests_delete1emptyfolders: 1 EXISTS but 0 by messages()} + ) ; + + # 0 EXISTS and 0 == messages() => deletion except INBOX + $imapT->mock( 'History', sub { ( q{* 0 EXISTS} ) } ) ; + $imapT->mock( 'messages', sub { [ ] } ) ; + $imapT->set_true( qw{ delete close unsubscribe } ) ; + $syncT->{dry_message} = q{ (not really since in a mocked test)} ; + tests_delete1emptyfolders_unit( + $syncT, + [ qw{ INBOX DELME1 DELME2 } ], + [ qw{ INBOX } ], + q{tests_delete1emptyfolders: 0 EXISTS 0 by messages() delete folders, keep INBOX} + ) ; + + note( 'Leaving tests_delete1emptyfolders()' ) ; + return ; +} + +sub tests_delete1emptyfolders_unit +{ + note( 'Entering tests_delete1emptyfolders_unit()' ) ; + + my $syncT = shift @ARG ; + my $folders1wanted_init_ref = shift @ARG ; + my $folders1wanted_after_ref = shift @ARG ; + my $comment = shift || q{delete1emptyfolders:} ; + + my @folders1wanted_init = @{ $folders1wanted_init_ref } ; + my @folders1wanted_after = @{ $folders1wanted_after_ref } ; + + @{ $syncT->{h1_folders_wanted} } = @folders1wanted_init ; + + is_deeply( $syncT->{h1_folders_wanted}, \@folders1wanted_init, qq{$comment, init check} ) ; + delete1emptyfolders( $syncT ) ; + is_deeply( $syncT->{h1_folders_wanted}, \@folders1wanted_after, qq{$comment, after check} ) ; + + note( 'Leaving tests_delete1emptyfolders_unit()' ) ; + return ; +} + +sub extract_header +{ + my $string = shift @ARG ; + + my ( $header ) = split /\n\n/x, $string ; + if ( ! $header ) { return( q{} ) ; } + #myprint( "[$header]\n" ) ; + return( $header ) ; +} + +sub tests_extract_header +{ + note( 'Entering tests_extract_header()' ) ; + +my $h = <<'EOM'; +Message-Id: <20100428101817.A66CB162474E@plume.est.belle> +Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST) +From: gilles@louloutte.dyndns.org (Gilles LAMIRAL) +EOM +chomp $h ; +ok( $h eq extract_header( +<<'EOM' +Message-Id: <20100428101817.A66CB162474E@plume.est.belle> +Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST) +From: gilles@louloutte.dyndns.org (Gilles LAMIRAL) + +body +lalala +EOM +), 'extract_header: 1') ; + + + + note( 'Leaving tests_extract_header()' ) ; + return ; +} + +sub decompose_header{ + my $string = shift @ARG ; + + # a hash, for a keyword header KEY value are list of strings [VAL1, VAL1_other, etc] + # Think of multiple "Received:" header lines. + my $header = { } ; + + my ($key, $val ) ; + my @line = split /\n|\r\n/x, $string ; + foreach my $line ( @line ) { + #myprint( "DDD $line\n" ) ; + # End of header + last if ( $line =~ m{^$}xo ) ; + # Key: value + if ( $line =~ m/(^[^:]+):\s(.*)/xo ) { + $key = $1 ; + $val = $2 ; + $debugdev and myprint( "DDD KV [$key] [$val]\n" ) ; + push @{ $header->{ $key } }, $val ; + # blanc and value => value from previous line continues + }elsif( $line =~ m/^(\s+)(.*)/xo ) { + $val = $2 ; + $debugdev and myprint( "DDD V [$val]\n" ) ; + @{ $header->{ $key } }[ $LAST ] .= " $val" if $key ; + # dirty line? + }else{ + next ; + } + } + + #myprint( Data::Dumper->Dump( [ $header ] ) ) ; + + return( $header ) ; +} + + +sub tests_decompose_header{ + note( 'Entering tests_decompose_header()' ) ; + + + my $header_dec ; + + $header_dec = decompose_header( +<<'EOH' +KEY_1: VAL_1 +KEY_2: VAL_2 + VAL_2_+ + VAL_2_++ +KEY_3: VAL_3 +KEY_1: VAL_1_other +KEY_4: VAL_4 + VAL_4_+ +KEY_5 BLANC: VAL_5 + +KEY_6_BAD_BODY: VAL_6 +EOH + ) ; + + ok( 'VAL_3' + eq $header_dec->{ 'KEY_3' }[0], 'decompose_header: VAL_3' ) ; + + ok( 'VAL_1' + eq $header_dec->{ 'KEY_1' }[0], 'decompose_header: VAL_1' ) ; + + ok( 'VAL_1_other' + eq $header_dec->{ 'KEY_1' }[1], 'decompose_header: VAL_1_other' ) ; + + ok( 'VAL_2 VAL_2_+ VAL_2_++' + eq $header_dec->{ 'KEY_2' }[0], 'decompose_header: VAL_2 VAL_2_+ VAL_2_++' ) ; + + ok( 'VAL_4 VAL_4_+' + eq $header_dec->{ 'KEY_4' }[0], 'decompose_header: VAL_4 VAL_4_+' ) ; + + ok( ' VAL_5' + eq $header_dec->{ 'KEY_5 BLANC' }[0], 'decompose_header: KEY_5 BLANC' ) ; + + ok( not( defined $header_dec->{ 'KEY_6_BAD_BODY' }[0] ), 'decompose_header: KEY_6_BAD_BODY' ) ; + + + $header_dec = decompose_header( +<<'EOH' +Message-Id: <20100428101817.A66CB162474E@plume.est.belle> +Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST) +From: gilles@louloutte.dyndns.org (Gilles LAMIRAL) +EOH + ) ; + + ok( '<20100428101817.A66CB162474E@plume.est.belle>' + eq $header_dec->{ 'Message-Id' }[0], 'decompose_header: 1' ) ; + + $header_dec = decompose_header( +<<'EOH' +Return-Path: +Received: by plume.est.belle (Postfix, from userid 1000) + id 120A71624742; Wed, 28 Apr 2010 01:46:40 +0200 (CEST) +Subject: test:eekahceishukohpe +EOH +) ; + ok( +'by plume.est.belle (Postfix, from userid 1000) id 120A71624742; Wed, 28 Apr 2010 01:46:40 +0200 (CEST)' + eq $header_dec->{ 'Received' }[0], 'decompose_header: 2' ) ; + + $header_dec = decompose_header( +<<'EOH' +Received: from plume (localhost [127.0.0.1]) + by plume.est.belle (Postfix) with ESMTP id C6EB73F6C9 + for ; Mon, 26 Nov 2007 10:39:06 +0100 (CET) +Received: from plume [192.168.68.7] + by plume with POP3 (fetchmail-6.3.6) + for (single-drop); Mon, 26 Nov 2007 10:39:06 +0100 (CET) +EOH + ) ; + ok( + 'from plume (localhost [127.0.0.1]) by plume.est.belle (Postfix) with ESMTP id C6EB73F6C9 for ; Mon, 26 Nov 2007 10:39:06 +0100 (CET)' + eq $header_dec->{ 'Received' }[0], 'decompose_header: 3' ) ; + ok( + 'from plume [192.168.68.7] by plume with POP3 (fetchmail-6.3.6) for (single-drop); Mon, 26 Nov 2007 10:39:06 +0100 (CET)' + eq $header_dec->{ 'Received' }[1], 'decompose_header: 3' ) ; + +# Bad header beginning with a blank character + $header_dec = decompose_header( +<<'EOH' + KEY_1: VAL_1 +KEY_2: VAL_2 + VAL_2_+ + VAL_2_++ +KEY_3: VAL_3 +KEY_1: VAL_1_other +EOH + ) ; + + ok( 'VAL_3' + eq $header_dec->{ 'KEY_3' }[0], 'decompose_header: Bad header VAL_3' ) ; + + ok( 'VAL_1_other' + eq $header_dec->{ 'KEY_1' }[0], 'decompose_header: Bad header VAL_1_other' ) ; + + ok( 'VAL_2 VAL_2_+ VAL_2_++' + eq $header_dec->{ 'KEY_2' }[0], 'decompose_header: Bad header VAL_2 VAL_2_+ VAL_2_++' ) ; + + note( 'Leaving tests_decompose_header()' ) ; + return ; +} + +sub tests_epoch +{ + note( 'Entering tests_epoch()' ) ; + + ok( '1282658400' eq epoch( '24-Aug-2010 16:00:00 +0200' ), 'epoch 24-Aug-2010 16:00:00 +0200 -> 1282658400' ) ; + ok( '1282658400' eq epoch( '24-Aug-2010 14:00:00 +0000' ), 'epoch 24-Aug-2010 14:00:00 +0000 -> 1282658400' ) ; + ok( '1282658400' eq epoch( '24-Aug-2010 12:00:00 -0200' ), 'epoch 24-Aug-2010 12:00:00 -0200 -> 1282658400' ) ; + ok( '1282658400' eq epoch( '24-Aug-2010 16:01:00 +0201' ), 'epoch 24-Aug-2010 16:01:00 +0201 -> 1282658400' ) ; + ok( '1282658400' eq epoch( '24-Aug-2010 14:01:00 +0001' ), 'epoch 24-Aug-2010 14:01:00 +0001 -> 1282658400' ) ; + + ok( '1280671200' eq epoch( '1-Aug-2010 16:00:00 +0200' ), 'epoch 1-Aug-2010 16:00:00 +0200 -> 1280671200' ) ; + ok( '1280671200' eq epoch( '1-Aug-2010 14:00:00 +0000' ), 'epoch 1-Aug-2010 14:00:00 +0000 -> 1280671200' ) ; + ok( '1280671200' eq epoch( '1-Aug-2010 12:00:00 -0200' ), 'epoch 1-Aug-2010 12:00:00 -0200 -> 1280671200' ) ; + ok( '1280671200' eq epoch( '1-Aug-2010 16:01:00 +0201' ), 'epoch 1-Aug-2010 16:01:00 +0201 -> 1280671200' ) ; + ok( '1280671200' eq epoch( '1-Aug-2010 14:01:00 +0001' ), 'epoch 1-Aug-2010 14:01:00 +0001 -> 1280671200' ) ; + + is( '1280671200', epoch( '1-Aug-2010 14:01:00 +0001' ), 'epoch 1-Aug-2010 14:01:00 +0001 -> 1280671200' ) ; + is( '946684800', epoch( '00-Jan-0000 00:00:00 +0000' ), 'epoch 1-Aug-2010 14:01:00 +0001 -> 1280671200' ) ; + + note( 'Leaving tests_epoch()' ) ; + return ; +} + +sub epoch +{ + # incoming format: + # internal date 24-Aug-2010 16:00:00 +0200 + + # outgoing format: epoch + + + my $d = shift @ARG ; + return(q{}) if not defined $d; + + my ( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m ) ; + my $time ; + + if ( $d =~ m{(\d{1,2})-([A-Z][a-z]{2})-(\d{4})\s(\d{2}):(\d{2}):(\d{2})\s((?:\+|-))(\d{2})(\d{2})}xo ) { + #myprint( "internal: [$1][$2][$3][$4][$5][$6][$7][$8][$9]\n" ) ; + ( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m ) + = ( $1, $2, $3, $4, $5, $6, $7, $8, $9 ) ; + #myprint( "( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m )\n" ) ; + + $sign = +1 if ( '+' eq $sign ) ; + $sign = $MINUS_ONE if ( '-' eq $sign ) ; + + if ( 0 == $mday ) { + myprint( "buggy day in $d. Fixed to 01\n" ) ; + $mday = '01' ; + } + $time = timegm( $sec, $min, $hour, $mday, $month_abrev{$month}, $year ) + - $sign * ( 3600 * $zone_h + 60 * $zone_m ) ; + + #myprint( "$time ", scalar localtime($time), "\n"); + } + return( $time ) ; +} + +sub tests_add_header +{ + note( 'Entering tests_add_header()' ) ; + + ok( 'Message-Id: ' eq add_header(), 'add_header no arg' ) ; + ok( 'Message-Id: <123456789@imapsync>' eq add_header( '123456789' ), 'add_header 123456789' ) ; + + note( 'Leaving tests_add_header()' ) ; + return ; +} + +sub add_header +{ + my $header_uid = shift || 'mistake' ; + my $header_Message_Id = 'Message-Id: <' . $header_uid . '@imapsync>' ; + return( $header_Message_Id ) ; +} + + + + +sub tests_max_line_length +{ + note( 'Entering tests_max_line_length()' ) ; + + ok( 0 == max_line_length( q{} ), 'max_line_length: 0 == null string' ) ; + ok( 1 == max_line_length( "\n" ), 'max_line_length: 1 == \n' ) ; + ok( 1 == max_line_length( "\n\n" ), 'max_line_length: 1 == \n\n' ) ; + ok( 1 == max_line_length( "\n" x 500 ), 'max_line_length: 1 == 500 \n' ) ; + ok( 1 == max_line_length( 'a' ), 'max_line_length: 1 == a' ) ; + ok( 2 == max_line_length( "a\na" ), 'max_line_length: 2 == a\na' ) ; + ok( 2 == max_line_length( "a\na\n" ), 'max_line_length: 2 == a\na\n' ) ; + ok( 3 == max_line_length( "a\nab\n" ), 'max_line_length: 3 == a\nab\n' ) ; + ok( 3 == max_line_length( "a\nab\n" x 1_000 ), 'max_line_length: 3 == 1_000 a\nab\n' ) ; + ok( 3 == max_line_length( "a\nab\nabc" ), 'max_line_length: 3 == a\nab\nabc' ) ; + + ok( 4 == max_line_length( "a\nab\nabc\n" ), 'max_line_length: 4 == a\nab\nabc\n' ) ; + ok( 5 == max_line_length( "a\nabcd\nabc\n" ), 'max_line_length: 5 == a\nabcd\nabc\n' ) ; + ok( 5 == max_line_length( "a\nabcd\nabc\n\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd" ), 'max_line_length: 5 == a\nabcd\nabc\n\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd' ) ; + + note( 'Leaving tests_max_line_length()' ) ; + return ; +} + +sub max_line_length +{ + my $string = shift @ARG ; + my $max = 0 ; + + while ( $string =~ m/([^\n]*\n?)/msxg ) { + $max = max( $max, length $1 ) ; + } + return( $max ) ; +} + +sub set_checknoabletosearch +{ + my $mysync = shift @ARG ; + if ( defined $mysync->{ checknoabletosearch } ) + { + return ; + } + elsif ( $mysync->{ justfolders } ) + { + $mysync->{ checknoabletosearch } = 0 ; + } + else + { + $mysync->{ checknoabletosearch } = 1 ; + } + return ; +} + + +sub tests_setlogfile +{ + note( 'Entering tests_setlogfile()' ) ; + + my $mysync = {} ; + $mysync->{ logdir } = 'vallogdir' ; + is( 'vallogdir/vallogfile.txt', setlogfile( $mysync, 'vallogfile.txt' ), + 'setlogfile: logdir vallogdir, vallogfile.txt => vallogdir/vallogfile.txt' ) ; + + SKIP: { + skip( 'Too hard to have a well known timezone on Windows', 9 ) if ( 'MSWin32' eq $OSNAME ) ; + + local $ENV{TZ} = 'GMT' ; + + $mysync = { + timestart => 2, + } ; + + is( '1970_01_01_00_00_02_000__.txt', setlogfile( $mysync ), + 'setlogfile: default is like 1970_01_01_00_00_02_000__.txt' ) ; + + $mysync = { + timestart => 2, + user1 => 'user1', + user2 => 'user2', + abort => 1, + } ; + + is( '1970_01_01_00_00_02_000_user1_user2_abort.txt', setlogfile( $mysync ), + 'setlogfile: default abort is like 1970_01_01_00_00_02_000_user1_user2_abort.txt' ) ; + + $mysync = { + timestart => 2, + user1 => 'user1', + user2 => 'user2', + } ; + + is( '1970_01_01_00_00_02_000_user1_user2_remote.txt', setlogfile( $mysync, undef, '_remote' ), + 'setlogfile: default with _remote is like 1970_01_01_00_00_02_000_user1_user2_remote.txt' ) ; + + $mysync = { + timestart => 2, + user1 => 'user1', + user2 => 'user2', + abort => 1, + } ; + + is( '1970_01_01_00_00_02_000_user1_user2_remote_abort.txt', setlogfile( $mysync, undef, '_remote' ), + 'setlogfile: default abort with _remote is like 1970_01_01_00_00_02_000_user1_user2_remote_abort.txt' ) ; + + + $mysync = { + timestart => 2, + user1 => 'user1', + user2 => 'user2', + } ; + + is( '1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ), + 'setlogfile: default is like 1970_01_01_00_00_02_000_user1_user2.txt' ) ; + + $mysync->{logdir} = undef ; + $mysync->{logfile} = undef ; + is( '1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ), + 'setlogfile: logdir undef, 1970_01_01_00_00_02_000_user1_user2.txt' ) ; + + $mysync->{logdir} = q{} ; + $mysync->{logfile} = undef ; + is( '1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ), + 'setlogfile: logdir empty, 1970_01_01_00_00_02_000_user1_user2.txt' ) ; + + $mysync->{logdir} = 'vallogdir' ; + $mysync->{logfile} = undef ; + is( 'vallogdir/1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ), + 'setlogfile: logdir vallogdir, vallogdir/1970_01_01_00_00_02_000_user1_user2.txt' ) ; + + $mysync = { + user1 => 'us/er1a*|?:"<>b', + user2 => 'u/ser2a*|?:"<>b', + } ; + + is( '1970_01_01_00_00_00_000_us_er1a_______b_u_ser2a_______b.txt', setlogfile( $mysync ), + 'setlogfile: logdir undef, 1970_01_01_00_00_00_000_us_er1a_______b_u_ser2a_______b.txt' ) ; + + } ; + + note( 'Leaving tests_setlogfile()' ) ; + return ; +} + + +sub setlogfile +{ + my $mysync = shift @ARG ; + my $given = shift @ARG ; + my $supplement = shift @ARG || '' ; + + # When aborting another process the log file name finishes with "_abort.txt" + my $abort_suffix = ( $mysync->{ abort } ) ? '_abort' : q{} ; + + my $suffix = logfilesuffix( $mysync, $supplement . $abort_suffix ) ; + + my $logdir = $mysync->{ logdir } || '' ; + + my $logfile ; + if ( defined $given ) + { + if ( $logdir ) + { + $logfile = "$logdir/$given" ; + } + else + { + $logfile = "$given" ; + } + } + else + { + $logfile = logfile( $mysync->{ timestart }, $suffix, $logdir ) ; + } + + return( $logfile ) ; +} + + +sub tests_logfilesuffix +{ + note( 'Entering tests_logfilesuffix()' ) ; + + is( '_', logfilesuffix( ), 'logfilesuffix: no args => _' ) ; + my $mysync = { } ; + is( '_', logfilesuffix( $mysync ), 'logfilesuffix: undef => _' ) ; + $mysync->{ user1 } = 'valuser1' ; + $mysync->{ user2 } = 'valuser2' ; + is( 'valuser1_valuser2', logfilesuffix( $mysync ), 'logfilesuffix: valuser1 valuser2 => valuser1_valuser2' ) ; + is( 'valuser1_valuser2_suppl', logfilesuffix( $mysync, '_suppl' ), 'logfilesuffix: valuser1 valuser2 _suppl => valuser1_valuser2_suppl' ) ; + + note( 'Leaving tests_logfilesuffix()' ) ; + return ; +} + +sub logfilesuffix +{ + my $mysync = shift @ARG ; + my $supplement = shift @ARG || '' ; + + my $suffix = ( + filter_forbidden_characters( slash_to_underscore( $mysync->{ user1 } ) ) || q{} ) + . '_' + . ( filter_forbidden_characters( slash_to_underscore( $mysync->{ user2 } ) ) || q{} ) + . $supplement ; + + return $suffix ; +} + + + +sub tests_setlogdir +{ + note( 'Entering tests_setlogdir()' ) ; + + is( $DEFAULT_LOGDIR, setlogdir( ), "setlogdir: no args => $DEFAULT_LOGDIR" ) ; + + my $mysync = { } ; + is( $DEFAULT_LOGDIR, setlogdir( $mysync ), "setlogdir: no args => $DEFAULT_LOGDIR" ) ; + + $mysync->{ logdir } = '' ; + is( '', setlogdir( $mysync ), "setlogdir: logdir empty string => empty string" ) ; + is( '', $mysync->{ logdir }, "setlogdir: logdir empty string unchanged" ) ; + + $mysync->{ logdir } = 'vallogdir' ; + is( 'vallogdir', setlogdir( $mysync ), "setlogdir: logdir vallogdir => vallogdir" ) ; + is( 'vallogdir', $mysync->{ logdir }, "setlogdir: logdir vallogdir unchanged" ) ; + # Does a second call hurt? + is( 'vallogdir', setlogdir( $mysync ), "setlogdir: logdir vallogdir => vallogdir" ) ; + is( 'vallogdir', $mysync->{ logdir }, "setlogdir: logdir vallogdir unchanged" ) ; + + note( 'Leaving tests_setlogdir()' ) ; + return ; +} + + +sub setlogdir +{ + my $mysync = shift @ARG ; + + my $logdir = defined $mysync->{ logdir } ? $mysync->{ logdir } : $DEFAULT_LOGDIR ; + + return $logdir ; +} + + +sub tests_logfile +{ + note( 'Entering tests_logfile()' ) ; + + SKIP: { + # Too hard to have a well known timezone on Windows + skip( 'Too hard to have a well known timezone on Windows', 10 ) if ( 'MSWin32' eq $OSNAME ) ; + + local $ENV{TZ} = 'GMT' ; + { + POSIX::tzset unless ('MSWin32' eq $OSNAME) ; + is( '1970_01_01_00_00_00_000.txt', logfile( ), 'logfile: no args => 1970_01_01_00_00_00_000.txt' ) ; + is( '1970_01_01_00_00_00_000.txt', logfile( 0 ), 'logfile: 0 => 1970_01_01_00_00_00_000.txt' ) ; + is( '1970_01_01_00_01_01_000.txt', logfile( 61 ), 'logfile: 0 => 1970_01_01_00_01_01_000.txt' ) ; + is( '1970_01_01_00_01_01_234.txt', logfile( 61.234 ), 'logfile: 0 => 1970_01_01_00_01_01_234.txt' ) ; + is( '2010_08_24_14_00_00_000.txt', logfile( 1_282_658_400 ), 'logfile: 1_282_658_400 => 2010_08_24_14_00_00_000.txt' ) ; + is( '2010_08_24_14_01_01_000.txt', logfile( 1_282_658_461 ), 'logfile: 1_282_658_461 => 2010_08_24_14_01_01_000.txt' ) ; + is( '2010_08_24_14_01_01_000_poupinette.txt', logfile( 1_282_658_461, 'poupinette' ), 'logfile: 1_282_658_461 poupinette => 2010_08_24_14_01_01_000_poupinette.txt' ) ; + is( '2010_08_24_14_01_01_000_removeblanks.txt', logfile( 1_282_658_461, ' remove blanks ' ), 'logfile: 1_282_658_461 remove blanks => 2010_08_24_14_01_01_000_removeblanks.txt' ) ; + + is( '2010_08_24_14_01_01_234_poup.txt', logfile( 1_282_658_461.2347, 'poup' ), + 'logfile: 1_282_658_461.2347 poup => 2010_08_24_14_01_01_234_poup.txt' ) ; + + is( 'dirdir/2010_08_24_14_01_01_234_poup.txt', logfile( 1_282_658_461.2347, 'poup', 'dirdir' ), + 'logfile: 1_282_658_461.2347 poup dirdir => dirdir/2010_08_24_14_01_01_234_poup.txt' ) ; + + } + POSIX::tzset unless ('MSWin32' eq $OSNAME) ; + } ; + + note( 'Leaving tests_logfile()' ) ; + return ; +} + + +sub logfile +{ + my ( $time, $suffix, $dir ) = @_ ; + + $time ||= 0 ; + $suffix ||= q{} ; + $suffix =~ tr/ //ds ; + my $sep_suffix = ( $suffix ) ? '_' : q{} ; + $dir ||= q{} ; + my $sep_dir = ( $dir ) ? '/' : q{} ; + + my $date_str = year_month_day_hour_min_sec_ms( $time ) ; + + my $logfile = "${dir}${sep_dir}${date_str}${sep_suffix}${suffix}.txt" ; + return( $logfile ) ; +} + + + +sub tests_year_month_day_hour_min_sec_ms +{ + note( 'Entering tests_date_year_month_day_hour_min_sec_ms()' ) ; + + if ( 'MSWin32' eq $OSNAME ) + { + # Can not use $ENV{TZ} nor POSIX::tzset + like( year_month_day_hour_min_sec_ms( ), qr'1970_01_01_\d\d_00_00_000', 'year_month_day_hour_min_sec_ms: no args => match 1970_01_01_\d\d_00_00_000' ) ; + like( year_month_day_hour_min_sec_ms( 0 ), qr'1970_01_01_\d\d_00_00_000', 'year_month_day_hour_min_sec_ms: 0 => match 1970_01_01_\d\d_00_00_000' ) ; + like( year_month_day_hour_min_sec_ms( 1671706800.123 ), qr'2022_12_22_\d\d_00_00_122', 'year_month_day_hour_min_sec_ms: 123456789.123 => match 2022_12_22_\d\d_00_00_122' ) ; + + like( year_month_day_hour_min_sec_ms( -1 ), qr'19\d\d_\d\d_\d\d_\d\d_59_59_000', 'year_month_day_hour_min_sec_ms: -1 => 19\d\d_\d\d_\d\d_\d\d_59_59_000' ) ; + like( year_month_day_hour_min_sec_ms( -0.246 ), qr'19\d\d_\d\d_\d\d_\d\d_59_59_754', 'year_month_day_hour_min_sec_ms: -1 => 19\d\d_\d\d_\d\d_\d\d_59_59_754' ) ; + + like( year_month_day_hour_min_sec_ms( -32360400.135 ), qr'1968_12_22_\d\d_59_59_864', 'year_month_day_hour_min_sec_ms: -1 => 1968_12_22_\d\d_59_59_864' ) ; + } + else + { + local $ENV{TZ} = 'GMT' ; + { + POSIX::tzset unless ('MSWin32' eq $OSNAME) ; + is( '1970_01_01_00_00_00_000', year_month_day_hour_min_sec_ms( ), + 'year_month_day_hour_min_sec_ms: no args => 1970_01_01_00_00_00_000 GMT' ) ; + is( '1970_01_01_00_00_00_000', year_month_day_hour_min_sec_ms( 0 ), + 'year_month_day_hour_min_sec_ms: 0 => 1970_01_01_00_00_00_000 GMT' ) ; + is( '1973_11_29_21_33_09_122', year_month_day_hour_min_sec_ms( 123456789.123 ), + 'year_month_day_hour_min_sec_ms: 123456789.123 => 1973_11_29_21_33_09_122 GMT' ) ; + is( '1969_12_31_23_59_59_000', year_month_day_hour_min_sec_ms( -1 ), + 'year_month_day_hour_min_sec_ms: -1 => 1969_12_31_23_59_59_000 GMT' ) ; + is( '1969_12_31_23_59_59_754', year_month_day_hour_min_sec_ms( -0.246 ), + 'year_month_day_hour_min_sec_ms: -0.246 => 1969_12_31_23_59_59_754 GMT' ) ; + is( '1966_02_02_02_26_50_864', year_month_day_hour_min_sec_ms( -123456789.135 ), + 'year_month_day_hour_min_sec_ms: -123456789.135 => 1966_02_02_02_26_50_864 GMT' ) ; + } + POSIX::tzset unless ('MSWin32' eq $OSNAME) ; + } + note( 'Leaving tests_year_month_day_hour_min_sec_ms()' ) ; + return ; +} + +sub year_month_day_hour_min_sec_ms +{ + my $time = shift @ARG || 0 ; + + my $date_str = POSIX::strftime( '%Y_%m_%d_%H_%M_%S', localtime $time ) ; + # Because of ab tests or web accesses, more than one sync withing one second is possible + # so we add also milliseconds + $date_str .= sprintf "_%03d", fractional_of_floor( $time ) * 1000 ; + + return $date_str ; +} + + + +sub tests_fractional_of_floor +{ + note( 'Entering tests_fractional_of_floor()' ) ; + + is( 0, fractional_of_floor( ), 'fractional_of_floor: no args => 0' ) ; + is( 0, fractional_of_floor( 0 ), 'fractional_of_floor: 0 => 0' ) ; + is( 0, fractional_of_floor( '0' ), 'fractional_of_floor: 0 => 0' ) ; + is( 0, fractional_of_floor( 1 ), 'fractional_of_floor: 1 => 0' ) ; + is( 0, fractional_of_floor( '1' ), 'fractional_of_floor: 1 => 0' ) ; + is( 0, fractional_of_floor( -1 ), 'fractional_of_floor: -1 => 0' ) ; + is( 0, fractional_of_floor( '-1' ), 'fractional_of_floor: -1 => 0' ) ; + is( 0.234, fractional_of_floor( 1.234 ), 'fractional_of_floor: 1.234 => 0.234' ) ; + is( 0.234, fractional_of_floor( '1.234' ), 'fractional_of_floor: 1.234 => 0.234' ) ; + is( 0.766, fractional_of_floor( -1.234 ), 'fractional_of_floor: -1.234 => 0.766' ) ; + is( 0.766, fractional_of_floor( '-1.234' ), 'fractional_of_floor: -1.234 => 0.766' ) ; + is( 0.234, fractional_of_floor( 10.234 ), 'fractional_of_floor: 10.234 => 0.234' ) ; + is( 0.766, fractional_of_floor( -10.234 ), 'fractional_of_floor: -10.234 => 0.766' ) ; + + note( 'Leaving tests_fractional_of_floor()' ) ; + return ; +} + + + + +sub fractional_of_floor +{ + my $float = shift @ARG || 0 ; + + if ( $float - int( $float ) >= 0 ) + { + return( $float - int( $float ) ) ; + } + else + { + return( 1 - ( int( $float ) - $float ) ) ; + } +} + + + +sub tests_localtimez +{ + note( 'Entering tests_localtimez()' ) ; + note( "localtimez: " . localtimez( ) ) ; + if ( 'MSWin32' eq $OSNAME ) + { + like( localtimez( 0 ), qr'1970-01-01 \d\d:\d\d:\d\d', 'localtimez: 0 => match 1970-01-01 \d\d:\d\d:\d\d' ) ; + } + else + { + local $ENV{TZ} = 'GMT' ; + like( localtimez( 0 ), qr'1970-01-01 00:00:00 \+0000 (GMT|UTC)', 'localtimez: 0 => match 1970-01-01 00:00:00 +0000 GMT or UTC' ) ; + } + is( localtimez( ), localtimez( time ), 'localtimez: undef => equals currrent' ) ; + note( 'Leaving tests_localtimez()' ) ; + return ; +} + +sub localtimez +{ + my $time = shift @ARG ; + + $time = defined( $time ) ? $time : time ; + + my $datetimestr ; + + if ( 'MSWin32' eq $OSNAME ) + { + $datetimestr = POSIX::strftime( '%A %d %B %Y-%m-%d %H:%M:%S %z', localtime( $time ) ) ; + } + else + { + $datetimestr = POSIX::strftime( '%A %d %B %Y-%m-%d %H:%M:%S %z %Z', localtime( $time ) ) ; + } + #myprint( "$datetimestr\n" ) ; + return $datetimestr ; +} + + + +sub tests_slash_to_underscore +{ + note( 'Entering tests_slash_to_underscore()' ) ; + + is( undef, slash_to_underscore( ), 'slash_to_underscore: no parameters => undef' ) ; + is( '_', slash_to_underscore( '/' ), 'slash_to_underscore: / => _' ) ; + is( '_abc_def_', slash_to_underscore( '/abc/def/' ), 'slash_to_underscore: /abc/def/ => _abc_def_' ) ; + note( 'Leaving tests_slash_to_underscore()' ) ; + return ; +} + +sub slash_to_underscore +{ + my $string = shift @ARG ; + + if ( ! defined $string ) { return ; } + + $string =~ tr{/}{_} ; + + return( $string ) ; +} + + + + +sub tests_million_folders_baby_2 +{ + note( 'Entering tests_million_folders_baby_2()' ) ; + + my %long ; + @long{ 1 .. 900_000 } = (1) x 900_000 ; + #myprint( %long, "\n" ) ; + my $pasglop = 0 ; + foreach my $elem ( 1 .. 900_000 ) { + #$debug and myprint( "$elem " ) ; + if ( not exists $long{ $elem } ) { + $pasglop++ ; + } + } + ok( 0 == $pasglop, 'tests_million_folders_baby_2: search among 900_000' ) ; + # myprint( "$pasglop\n" ) ; + + note( 'Leaving tests_million_folders_baby_2()' ) ; + return ; +} + + + +sub tests_logfileprepa +{ + note( 'Entering tests_logfileprepa()' ) ; + + is( undef, logfileprepa( ), 'logfileprepa: no args => undef' ) ; + my $logfile = 'W/tmp/tests/tests_logfileprepa.txt' ; + is( 1, logfileprepa( $logfile ), 'logfileprepa: W/tmp/tests/tests_logfileprepa.txt => 1' ) ; + + note( 'Leaving tests_logfileprepa()' ) ; + return ; +} + +sub logfileprepa +{ + my $logfile = shift @ARG ; + + if ( ! defined( $logfile ) ) + { + return ; + }else + { + #myprint( "[$logfile]\n" ) ; + my $dirname = dirname( $logfile ) ; + do_valid_directory( $dirname ) || return( 0 ) ; + return( 1 ) ; + } +} + + +sub tests_teelaunch +{ + note( 'Entering tests_teelaunch()' ) ; + + is( undef, teelaunch( ), 'teelaunch: no args => undef' ) ; + my $mysync = {} ; + is( undef, teelaunch( $mysync ), 'teelaunch: arg empty {} => undef' ) ; + is( undef, teelaunch( $mysync, '' ), 'teelaunch: empty string => undef' ) ; + + # First time, learning IO::Tee intrasics + my $tee = teelaunch( $mysync, 'W/tmp/tests/tests_teelaunch.txt' ) ; + isa_ok( $tee, 'IO::Tee', 'teelaunch: logfile W/tmp/tests/tests_teelaunch.txt' ) ; + is( 1, print( $tee "Hi!\n" ), 'teelaunch: write Hi!') ; + is( "Hi!\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch.txt is Hi!\n' ) ; + is( 1, print( $tee "Hoo\n" ), 'teelaunch: write Hoo') ; + is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch.txt is Hi!\nHoo\n' ) ; + + # closing file handle so tee won't be happy + ($tee->handles)[0]->close ; + is( undef, print( $tee "Argh1\n" ), 'teelaunch: write Argh1') ; + is( undef, print( $tee "Argh2\n" ), 'teelaunch: write Argh2') ; + # write not done + is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch.txt is still Hi!\nHoo\n' ) ; + print join( ' ', $tee->handles ), "\n"; + is( 2, scalar $tee->handles, 'teelaunch: 2 handles') ; + shift @{*{$tee}}; + print join(' ', $tee->handles), "\n" ; + is( 1, scalar $tee->handles, 'teelaunch: 1 handle') ; + is( 1, print( $tee "Argh3\n" ), 'teelaunch: write Argh3 yeah') ; + + shift @{*{$tee}}; + # will not print anything now + is( 0, scalar $tee->handles, 'teelaunch: 0 handle') ; + is( 1, print( $tee "Argh 4\n" ), 'teelaunch: write Argh4 no') ; + + # Second time, lesson learnt IO::Tee + $tee = teelaunch( $mysync, 'W/tmp/tests/tests_teelaunch2.txt' ) ; + isa_ok( $tee, 'IO::Tee' , 'teelaunch: W/tmp/tests/tests_teelaunch2.txt' ) ; + is( 1, print( $tee "Hi!\n" ), 'teelaunch: write Hi!') ; + is( "Hi!\n", file_to_string( 'W/tmp/tests/tests_teelaunch2.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch2.txt is Hi!\n' ) ; + is( 1, print( $tee "Hoo\n" ), 'teelaunch: write Hoo') ; + is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch2.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch2.txt is Hi!\nHoo\n' ) ; + + is( 1, teefinish( $tee ), 'teefinish: return 1') ; + is( 1, print( $tee "Argh1\n" ), 'teelaunch: write Argh1') ; + is( 1, print( $tee "Argh2\n" ), 'teelaunch: write Argh2') ; + is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch2.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch2.txt is still Hi!\nHoo\n' ) ; + is( 1, teefinish( $tee ), 'teefinish: still return 1') ; + + note( 'Leaving tests_teelaunch()' ) ; + return ; +} + +sub teelaunch +{ + my $mysync = shift @ARG ; + my $logfile = shift @ARG ; + + if ( ! defined( $mysync ) ) + { + return ; + } + + if ( ! $logfile ) + { + return ; + } + + logfileprepa( $logfile ) || croak "Error no valid directory to write log file $logfile : $OS_ERROR" ; + + # To honor -T tainted mode. Could do better... + ( $logfile ) = $logfile =~ m{(.*)}x ; + # This is a log file opened during the whole sync + ## no critic (InputOutput::RequireBriefOpen) + if ( ! open my $logfile_handle, '>', $logfile ) + { + carp( "Can not open $logfile for write: $OS_ERROR" ) ; + return ; + } + else + { + binmode $logfile_handle, ":encoding(UTF-8)" ; + my $tee = IO::Tee->new( $logfile_handle, \*STDOUT ) ; + $tee->autoflush( 1 ) ; + return $tee ; + } +} + +sub teefinish +{ + my $tee = shift @ARG ; + + if ( ! defined( $tee ) ) { return ; } + + if ( 2 == scalar $tee->handles ) + { + my $handle = shift @{*{$tee}} ; + $handle->close ; + } + else + { + # nothing + } + return scalar $tee->handles ; +} + + +sub getpwuid_any_os +{ + my $uid = shift @ARG ; + + return( scalar getlogin ) if ( 'MSWin32' eq $OSNAME ) ; # Windows system + return( scalar getpwuid $uid ) ; # Unix system + + +} + + + +sub abortifneeded +{ + my $mysync = shift @ARG ; + if ( -e $mysync->{ abortfile } ) + { + myprint( "Asked to terminate by file $mysync->{ abortfile }\n" ) ; + do_and_print_stats( $mysync ) ; + myprint( "You should resynchronize those accounts by running a sync again,\n", + "since some messages and entire folders might still be missing on host2.\n" + ) ; + exit_clean( $mysync, $EXIT_BY_FILE ) ; + return ; + } + else + { + return ; + } +} + +sub simulong +{ + my $mysync = shift @ARG ; + + my $max_seconds = $mysync->{ simulong } ; + + if ( ! $max_seconds ) { return ; } + + my $division = 5 ; + my $last_count = int( $division * $max_seconds ) ; + $mysync->{ debug } and myprint "last_count $last_count = int( division $division * max_seconds $max_seconds)\n" ; + foreach my $i ( 1 .. ( $last_count ) ) { + myprint( "Are you still here ETA: " . ( $last_count - $i ) . "/$last_count msgs left\n" ) ; + #this one is for testing huge page behavior + #myprint( "Are you still here ETA: " . ($last_count - $i) . "/$last_count msgs left\n" . ( "Ah" x 40 . "\n") x 4000 ) ; + sleep( 1 / $division ) ; + abortifneeded( $mysync ) ; + } + + return ; +} + + + +sub printenv +{ + myprint( "Environment variables listing:\n", + ( map { "$_ => $ENV{$_}\n" } sort keys %ENV), + "Environment variables listing end\n" ) ; + return ; +} + + +sub unittestssuite +{ + my $mysync = shift @ARG ; + if ( ! ( $mysync->{ tests } or $mysync->{ testsdebug } or $mysync->{ testsunit } ) ) { + return ; + } + + my $test_builder = Test::More->builder ; + tests( $mysync ) ; + testsdebug( $mysync ) ; + testunitsession( $mysync ) ; + + cleanup_mess_from_tests( ) ; + + my @summary = $test_builder->summary() ; + my @details = $test_builder->details() ; + my $nb_tests_run = scalar( @summary ) ; + my $nb_tests_expected = $test_builder->expected_tests() ; + my $nb_tests_failed = count_0s( @summary ) ; + my $tests_failed = report_failures( @details ) ; + if ( $nb_tests_failed or ( $nb_tests_run != $nb_tests_expected ) ) { + #$test_builder->reset( ) ; + myprint( "Summary of tests: failed $nb_tests_failed tests, run $nb_tests_run tests, expected to run $nb_tests_expected tests.\n", + "List of failed tests:\n", $tests_failed ) ; + return $EXIT_TESTS_FAILED ; + } + return 0 ; +} + +sub cleanup_mess_from_tests +{ + undef @pipemess ; + undef @include ; + undef @exclude ; + undef @folderrec ; + undef @folderfirst ; + undef @folderlast ; + undef @h1_folders_all ; + undef %h1_folders_all ; + undef @h2_folders_all ; + undef %h2_folders_all ; + undef @h2_folders_from_1_wanted ; + undef %h2_folders_from_1_all ; + undef %requested_folder ; + + return ; +} + +sub after_get_options +{ + my $mysync = shift @ARG ; + my $numopt = shift @ARG ; + + + # exit with --help option or no option at all + $mysync->{ debug } and myprint( "numopt:$numopt\n" ) ; + + if ( $help or not $numopt ) { + myprint( usage( $mysync ) ) ; + exit ; + } + + return ; +} + +sub tests_remove_edging_blanks +{ + note( 'Entering tests_remove_edging_blanks()' ) ; + + is( undef, remove_edging_blanks( ), 'remove_edging_blanks: no args => undef' ) ; + is( 'abcd', remove_edging_blanks( 'abcd' ), 'remove_edging_blanks: abcd => abcd' ) ; + is( 'ab cd', remove_edging_blanks( ' ab cd ' ), 'remove_edging_blanks: " ab cd " => "ab cd"' ) ; + + note( 'Leaving tests_remove_edging_blanks()' ) ; + return ; +} + + + +sub remove_edging_blanks +{ + my $string = shift @ARG ; + if ( ! defined $string ) + { + return ; + } + $string =~ s,^ +| +$,,g ; + return $string ; +} + + +sub tests_sanitize +{ + note( 'Entering tests_remove_edging_blanks()' ) ; + + is( undef, sanitize( ), 'sanitize: no args => undef' ) ; + my $mysync = {} ; + + $mysync->{ host1 } = ' example.com ' ; + $mysync->{ user1 } = ' to to ' ; + $mysync->{ password1 } = ' sex is good! ' ; + is( undef, sanitize( $mysync ), 'sanitize: => undef' ) ; + is( 'example.com', $mysync->{ host1 }, 'sanitize: host1 " example.com " => "example.com"' ) ; + is( 'to to', $mysync->{ user1 }, 'sanitize: user1 " to to " => "to to"' ) ; + is( 'sex is good!', $mysync->{ password1 }, 'sanitize: password1 " sex is good! " => "sex is good!"' ) ; + note( 'Leaving tests_remove_edging_blanks()' ) ; + return ; +} + + +sub sanitize +{ + my $mysync = shift @ARG ; + if ( ! defined $mysync ) + { + return ; + } + + foreach my $parameter ( qw( host1 host2 user1 user2 password1 password2 ) ) + { + $mysync->{ $parameter } = remove_edging_blanks( $mysync->{ $parameter } ) ; + } + return ; +} + +sub easyany +{ + my $mysync = shift @ARG ; + + # Gmail + if ( $mysync->{gmail1} and $mysync->{gmail2} ) { + $mysync->{ debug } and myprint( "gmail1 gmail2\n") ; + gmail12( $mysync ) ; + return ; + } + if ( $mysync->{gmail1} ) { + $mysync->{ debug } and myprint( "gmail1\n" ) ; + gmail1( $mysync ) ; + } + if ( $mysync->{gmail2} ) { + $mysync->{ debug } and myprint( "gmail2\n" ) ; + gmail2( $mysync ) ; + } + # Office 365 + if ( $mysync->{office1} ) { + office1( $mysync ) ; + } + + if ( $mysync->{office2} ) { + office2( $mysync ) ; + } + + # Exchange + if ( $mysync->{exchange1} ) { + exchange1( $mysync ) ; + } + + if ( $mysync->{exchange2} ) { + exchange2( $mysync ) ; + } + + + # Domino + if ( $mysync->{domino1} ) { + domino1( $mysync ) ; + } + + if ( $mysync->{domino2} ) { + domino2( $mysync ) ; + } + + return ; +} + +# From and for https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt +sub gmail12 +{ + my $mysync = shift @ARG ; + # Gmail at host1 and host2 + $mysync->{host1} ||= 'imap.gmail.com' ; + $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ; + $mysync->{host2} ||= 'imap.gmail.com' ; + $mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ; + $mysync->{maxbytespersecond} ||= 20_000 ; # should be less than 10_000 when computed from Gmail documentation + $mysync->{maxbytesafter} ||= 1_000_000_000 ; # In fact it is documented as half: 500_000_000 + $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ; + $mysync->{maxsleep} = ( defined $mysync->{maxsleep} ) ? $mysync->{maxsleep} : $MAX_SLEEP ; ; + $mysync->{ skipcrossduplicates } = ( defined $mysync->{ skipcrossduplicates } ) ? $mysync->{ skipcrossduplicates } : 0 ; + $mysync->{ synclabels } = ( defined $mysync->{ synclabels } ) ? $mysync->{ synclabels } : 1 ; + $mysync->{ resynclabels } = ( defined $mysync->{ resynclabels } ) ? $mysync->{ resynclabels } : 1 ; + push @useheader, 'X-Gmail-Received', 'Message-Id' ; + push @exclude, '\[Gmail\]$' ; + push @folderlast, '[Gmail]/All Mail' ; + return ; +} + + +sub gmail1 +{ + my $mysync = shift @ARG ; + # Gmail at host2 + $mysync->{host1} ||= 'imap.gmail.com' ; + $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ; + $mysync->{maxbytespersecond} ||= 40_000 ; # should be 30_000 computed from by Gmail documentation + $mysync->{maxbytesafter} ||= 3_000_000_000 ; # + $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ; + $mysync->{maxsleep} = ( defined $mysync->{maxsleep} ) ? $mysync->{maxsleep} : $MAX_SLEEP ; ; + $mysync->{ skipcrossduplicates } = ( defined $mysync->{ skipcrossduplicates } ) ? $mysync->{ skipcrossduplicates } : 1 ; + + push @useheader, 'X-Gmail-Received', 'Message-Id' ; + push @{ $mysync->{ regextrans2 } }, 's,\[Gmail\].,,' ; + push @folderlast, '[Gmail]/All Mail' ; + return ; +} + +sub gmail2 +{ + my $mysync = shift @ARG ; + # Gmail at host2 + $mysync->{ host2 } ||= 'imap.gmail.com' ; + $mysync->{ ssl2 } = ( defined $mysync->{ ssl2 } ) ? $mysync->{ ssl2 } : 1 ; + $mysync->{ maxbytespersecond } ||= 20_000 ; # should be less than 10_000 computed from by Gmail documentation + $mysync->{ maxbytesafter } ||= 1_000_000_000 ; # In fact it is documented as half: 500_000_000 + $mysync->{ automap } = ( defined $mysync->{ automap } ) ? $mysync->{ automap } : 1 ; + $mysync->{ expunge1 } = ( defined $mysync->{ expunge1 } ) ? $mysync->{ expunge1 } : 1 ; + $mysync->{ addheader } = ( defined $mysync->{ addheader } ) ? $mysync->{ addheader } : 1 ; + $mysync->{ maxsleep } = ( defined $mysync->{ maxsleep } ) ? $mysync->{ maxsleep } : $MAX_SLEEP ; ; + + #$mysync->{ maxsize } = ( defined $mysync->{ maxsize } ) ? $mysync->{ maxsize } : $GMAIL_MAXSIZE ; + + if ( ! $mysync->{ noexclude } ) { + push @exclude, '\[Gmail\]$' ; + } + push @useheader, 'Message-Id' ; + push @{ $mysync->{ regextrans2 } }, 's,\[Gmail\].,,' ; + + # push @{ $mysync->{ regextrans2 } }, 's/[ ]+/_/g' ; # is now replaced + # by the two more specific following regexes, + # they remove just the beginning and trailing blanks, not all. + push @{ $mysync->{ regextrans2 } }, 's,^ +| +$,,g' ; + push @{ $mysync->{ regextrans2 } }, 's,/ +| +/,/,g' ; + # + push @{ $mysync->{ regextrans2 } }, q{s/['\\^"]/_/g} ; # Verified this + push @folderlast, '[Gmail]/All Mail' ; + return ; +} + + +# From https://imapsync.lamiral.info/FAQ.d/FAQ.Exchange.txt +sub office1 +{ + # Office 365 at host1 + my $mysync = shift @ARG ; + + output( $mysync, q{Option --office1 is like: --host1 outlook.office365.com --ssl1 --exclude "^Files$"} . "\n" ) ; + output( $mysync, "Option --office1 (cont) : unless overrided with --host1 otherhost --nossl1 --noexclude\n" ) ; + $mysync->{host1} ||= 'outlook.office365.com' ; + $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ; + if ( ! $mysync->{noexclude} ) { + push @exclude, '^Files$' ; + } + return ; +} + + +sub office2 +{ + # Office 365 at host2 + my $mysync = shift @ARG ; + output( $mysync, qq{Option --office2 is like: --host2 outlook.office365.com --ssl2 --maxsize 45_000_000 --maxmessagespersecond 4\n} ) ; + output( $mysync, qq{Option --office2 (cont) : --disarmreadreceipts --regexmess "wrap 10500" --f1f2 "Files=Files_renamed_by_imapsync"\n} ) ; + output( $mysync, qq{Option --office2 (cont) : unless overrided with --host2 otherhost --nossl2 ... --nodisarmreadreceipts --noregexmess\n} ) ; + output( $mysync, qq{Option --office2 (cont) : and --nof1f2 to avoid Files folder renamed to Files_renamed_by_imapsync\n} ) ; + $mysync->{host2} ||= 'outlook.office365.com' ; + $mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ; + $mysync->{ maxsize } ||= 45_000_000 ; + $mysync->{maxmessagespersecond} ||= 4 ; + #push @{ $mysync->{ regexflag } }, 's/\\\\Flagged//g' ; # No problem without! tested 2018_09_10 + $disarmreadreceipts = ( defined $disarmreadreceipts ) ? $disarmreadreceipts : 1 ; + # I dislike double negation but here is one + if ( ! $mysync->{noregexmess} ) + { + push @regexmess, 's,(.{10239}),$1\r\n,g' ; + } + # and another... + if ( ! $mysync->{nof1f2} ) + { + push @{ $mysync->{f1f2} }, 'Files=Files_renamed_by_imapsync' ; + } + return ; +} + +sub exchange1 +{ + # Exchange 2010/2013 at host1 + my $mysync = shift @ARG ; + output( $mysync, "Option --exchange1 does nothing (except printing this line...)\n" ) ; + # Well nothing to do so far + return ; +} + +sub exchange2 +{ + # Exchange 2010/2013 at host2 + my $mysync = shift @ARG ; + output( $mysync, "Option --exchange2 is like: --maxsize 10_000_000 --maxmessagespersecond 4 --disarmreadreceipts\n" ) ; + output( $mysync, "Option --exchange2 (cont) : --regexflag del Flagged --regexmess wrap 10500\n" ) ; + output( $mysync, "Option --exchange2 (cont) : unless overrided with --maxsize xxx --nodisarmreadreceipts --noregexflag --noregexmess\n" ) ; + $mysync->{ maxsize } ||= 10_000_000 ; + $mysync->{maxmessagespersecond} ||= 4 ; + $disarmreadreceipts = ( defined $disarmreadreceipts ) ? $disarmreadreceipts : 1 ; + # I dislike double negation but here are two + if ( ! $mysync->{noregexflag} ) { + push @{ $mysync->{ regexflag } }, 's/\\\\Flagged//g' ; + } + if ( ! $mysync->{noregexmess} ) { + push @regexmess, 's,(.{10239}),$1\r\n,g' ; + } + return ; +} + +sub domino1 +{ + # Domino at host1 + my $mysync = shift @ARG ; + + $mysync->{ sep1 } = q{\\} ; + $prefix1 = q{} ; + $messageidnodomain = ( defined $messageidnodomain ) ? $messageidnodomain : 1 ; + return ; +} + +sub domino2 +{ + # Domino at host1 + my $mysync = shift @ARG ; + + $mysync->{ sep2 } = q{\\} ; + $prefix2 = q{} ; + $messageidnodomain = ( defined $messageidnodomain ) ? $messageidnodomain : 1 ; + push @{ $mysync->{ regextrans2 } }, 's,^Inbox\\\\(.*),$1,i' ; + return ; +} + + +sub tests_resolv +{ + note( 'Entering tests_resolv()' ) ; + + # is( , resolv( ), 'resolv: => ' ) ; + is( undef, resolv( ), 'resolv: no args => undef' ) ; + is( undef, resolv( q{} ), 'resolv: empty string => undef' ) ; + is( undef, resolv( 'hostnotexist' ), 'resolv: hostnotexist => undef' ) ; + is( '127.0.0.1', resolv( '127.0.0.1' ), 'resolv: 127.0.0.1 => 127.0.0.1' ) ; + is( '127.0.0.1', resolv( 'localhost' ), 'resolv: localhost => 127.0.0.1' ) ; + is( '2001:41d0:2:84e0::1', resolv( 'imapsync.lamiral.info' ), 'resolv: imapsync.lamiral.info => 2001:41d0:2:84e0::1' ) ; + + # ip6-localhost ( in /etc/hosts ) + is( '::1', resolv( 'ip6-localhost' ), 'resolv: ip6-localhost => ::1' ) ; + is( '::1', resolv( '::1' ), 'resolv: ::1 => ::1' ) ; + # ks2ipv6 now has CNAME ks6ipv6 + is( '2001:41d0:8:d8b6::1', resolv( '2001:41d0:8:d8b6::1' ), 'resolv: 2001:41d0:8:d8b6::1 => 2001:41d0:8:d8b6::1' ) ; + is( '2001:41d0:8:9951::1', resolv( 'ks6ipv6.lamiral.info' ), 'resolv: ks6ipv6.lamiral.info => 2001:41d0:8:9951::1' ) ; + # ks6 + is( '2001:41d0:8:9951::1', resolv( '2001:41d0:8:9951::1' ), 'resolv: 2001:41d0:8:9951::1 => 2001:41d0:8:9951::1' ) ; + is( '2001:41d0:8:9951::1', resolv( 'ks6ipv6.lamiral.info' ), 'resolv: ks6ipv6.lamiral.info => 2001:41d0:8:9951::1' ) ; + # ks3 + is( '2001:41d0:8:bebd::1', resolv( '2001:41d0:8:bebd::1' ), 'resolv: 2001:41d0:8:bebd::1 => 2001:41d0:8:bebd::1' ) ; + is( '2001:41d0:8:bebd::1', resolv( 'ks3ipv6.lamiral.info' ), 'resolv: ks3ipv6.lamiral.info => 2001:41d0:8:bebd::1' ) ; + + + note( 'Leaving tests_resolv()' ) ; + return ; +} + + + +sub resolv +{ + my $host = shift @ARG ; + + if ( ! $host ) { return ; } + my $addr ; + if ( defined &Socket::getaddrinfo ) { + $addr = resolv_with_getaddrinfo( $host ) ; + return( $addr ) ; + } + + + + my $iaddr = inet_aton( $host ) ; + if ( ! $iaddr ) { return ; } + $addr = inet_ntoa( $iaddr ) ; + + return $addr ; +} + +sub resolv_with_getaddrinfo +{ + my $host = shift @ARG ; + + $sync->{ debug } and myprint( "Entering resolv_with_getaddrinfo( $host )\n" ) ; + if ( ! $host ) { return ; } + + my ( $err_getaddrinfo, @res ) = Socket::getaddrinfo( $host, "", { socktype => Socket::SOCK_RAW } ) ; + if ( $err_getaddrinfo ) { + myprint( "Cannot getaddrinfo of $host: $err_getaddrinfo\n" ) ; + return ; + } + + my @addr ; + while( my $ai = shift @res ) { + my ( $err_getnameinfo, $ipaddr ) = Socket::getnameinfo( $ai->{addr}, Socket::NI_NUMERICHOST(), Socket::NIx_NOSERV() ) ; + if ( $err_getnameinfo ) { + myprint( "Cannot getnameinfo of $host: $err_getnameinfo\n" ) ; + return ; + }else{ + $sync->{ debug } and myprint( "$host => $ipaddr\n" ) ; + push @addr, $ipaddr ; + my $reverse ; + ( $err_getnameinfo, $reverse ) = Socket::getnameinfo( $ai->{addr}, 0, Socket::NIx_NOSERV() ) ; + $sync->{ debug } and myprint( "$host => $ipaddr => $reverse\n" ) ; + } + $sync->{ debug } and myprint( "$host => $ipaddr\n" ) ; + + } + $sync->{ debug } and myprint( "Leaving resolv_with_getaddrinfo( $host => $addr[0])\n" ) ; + return $addr[0] ; +} + +sub tests_resolvrev +{ + note( 'Entering tests_resolvrev()' ) ; + + # is( , resolvrev( ), 'resolvrev: => ' ) ; + is( undef, resolvrev( ), 'resolvrev: no args => undef' ) ; + is( undef, resolvrev( q{} ), 'resolvrev: empty string => undef' ) ; + is( undef, resolvrev( 'hostnotexist' ), 'resolvrev: hostnotexist => undef' ) ; + is( 'localhost', resolvrev( '127.0.0.1' ), 'resolvrev: 127.0.0.1 => localhost' ) ; + is( 'localhost', resolvrev( 'localhost' ), 'resolvrev: localhost => localhost' ) ; + is( 'ks.lamiral.info', resolvrev( 'imapsync.lamiral.info' ), 'resolvrev: imapsync.lamiral.info => ks.lamiral.info' ) ; + + # ip6-localhost ( in /etc/hosts ) + is( 'ip6-localhost', resolvrev( 'ip6-localhost' ), 'resolvrev: ip6-localhost => ip6-localhost' ) ; + is( 'ip6-localhost', resolvrev( '::1' ), 'resolvrev: ::1 => ip6-localhost' ) ; + # ks2 + is( 'ks6ipv6.lamiral.info', resolvrev( '2001:41d0:8:d8b6::1' ), 'resolvrev: 2001:41d0:8:d8b6::1 => ks6ipv6.lamiral.info' ) ; + is( 'ks6ipv6.lamiral.info', resolvrev( 'ks6ipv6.lamiral.info' ), 'resolvrev: ks6ipv6.lamiral.info => ks6ipv6.lamiral.info' ) ; + # ks3 + is( 'ks3ipv6.lamiral.info', resolvrev( '2001:41d0:8:bebd::1' ), 'resolvrev: 2001:41d0:8:bebd::1 => ks3ipv6.lamiral.info' ) ; + is( 'ks3ipv6.lamiral.info', resolvrev( 'ks3ipv6.lamiral.info' ), 'resolvrev: ks3ipv6.lamiral.info => ks3ipv6.lamiral.info' ) ; + + + note( 'Leaving tests_resolvrev()' ) ; + return ; +} + +sub resolvrev +{ + my $host = shift @ARG ; + + if ( ! $host ) { return ; } + + if ( defined &Socket::getaddrinfo ) { + my $name = resolvrev_with_getaddrinfo( $host ) ; + return( $name ) ; + } + + return ; +} + +sub resolvrev_with_getaddrinfo +{ + my $host = shift @ARG ; + + if ( ! $host ) { return ; } + + my ( $err, @res ) = Socket::getaddrinfo( $host, "", { socktype => Socket::SOCK_RAW } ) ; + if ( $err ) { + myprint( "Cannot getaddrinfo of $host: $err\n" ) ; + return ; + } + + my @name ; + while( my $ai = shift @res ) { + my ( $err, $reverse ) = Socket::getnameinfo( $ai->{addr}, 0, Socket::NIx_NOSERV() ) ; + if ( $err ) { + myprint( "Cannot getnameinfo of $host: $err\n" ) ; + return ; + } + $sync->{ debug } and myprint( "$host => $reverse\n" ) ; + push @name, $reverse ; + } + + return $name[0] ; +} + + + +sub tests_imapsping +{ + note( 'Entering tests_imapsping()' ) ; + + is( undef, imapsping( ), 'imapsping: no args => undef' ) ; + is( undef, imapsping( 'hostnotexist' ), 'imapsping: hostnotexist => undef' ) ; + is( 1, imapsping( 'imapsync.lamiral.info' ), 'imapsping: imapsync.lamiral.info => 1' ) ; + is( 1, imapsping( 'ks6ipv6.lamiral.info' ), 'imapsping: ks6ipv6.lamiral.info => 1' ) ; + note( 'Leaving tests_imapsping()' ) ; + return ; +} + +sub imapsping +{ + my $host = shift @ARG ; + return tcpping( $host, $IMAP_SSL_PORT ) ; +} + +sub tests_tcpping +{ + note( 'Entering tests_tcpping()' ) ; + + is( undef, tcpping( ), 'tcpping: no args => undef' ) ; + is( undef, tcpping( 'hostnotexist' ), 'tcpping: one arg => undef' ) ; + is( undef, tcpping( undef, 888 ), 'tcpping: arg undef, port => undef' ) ; + is( undef, tcpping( 'hostnotexist', 993 ), 'tcpping: hostnotexist 993 => undef' ) ; + is( undef, tcpping( 'hostnotexist', 888 ), 'tcpping: hostnotexist 888 => undef' ) ; + is( 1, tcpping( 'imapsync.lamiral.info', 993 ), 'tcpping: imapsync.lamiral.info 993 => 1' ) ; + is( 0, tcpping( 'imapsync.lamiral.info', 888 ), 'tcpping: imapsync.lamiral.info 888 => 0' ) ; + is( 1, tcpping( '5.135.158.182', 993 ), 'tcpping: 5.135.158.182 993 => 1' ) ; + is( 0, tcpping( '5.135.158.182', 888 ), 'tcpping: 5.135.158.182 888 => 0' ) ; + + # Net::Ping supports ipv6 only after release 1.50 + # http://cpansearch.perl.org/src/RURBAN/Net-Ping-2.59/Changes + # Anyway I plan to avoid Net-Ping for that too long standing feature + # Net-Ping is integrated in Perl itself, who knows ipv6 for a long time + is( 1, tcpping( '2001:41d0:8:d8b6::1', 993 ), 'tcpping: 2001:41d0:8:d8b6::1 993 => 1' ) ; + is( 0, tcpping( '2001:41d0:8:d8b6::1', 888 ), 'tcpping: 2001:41d0:8:d8b6::1 888 => 0' ) ; + + note( 'Leaving tests_tcpping()' ) ; + return ; +} + +sub tcpping +{ + if ( 2 != scalar( @ARG ) ) { + return ; + } + my ( $host, $port ) = @ARG ; + if ( ! $host ) { return ; } + if ( ! $port ) { return ; } + + my $mytimeout = $TCP_PING_TIMEOUT ; + require Net::Ping ; + #my $p = Net::Ping->new( 'tcp' ) ; + my $p = Net::Ping->new( ) ; + $p->{port_num} = $port ; + $p->service_check( 1 ) ; + $p->hires( 1 ) ; + my ($ping_ok, $rtt, $ip ) = $p->ping( $host, $mytimeout ) ; + if ( ! defined $ping_ok ) { return ; } + my $rtt_approx = sprintf( "%.3f", $rtt ) ; + $sync->{ debug } and myprint( "Host $host timeout $mytimeout port $port ok $ping_ok ip $ip acked in $rtt_approx s\n" ) ; + $p->close( ) ; + if( $ping_ok ) { + return 1 ; + }else{ + return 0 ; + } +} + +sub tests_sslcheck +{ + note( 'Entering tests_sslcheck()' ) ; + + my $mysync ; + + is( undef, sslcheck( $mysync ), 'sslcheck: no sslcheck => undef' ) ; + + $mysync = { + sslcheck => 1, + } ; + + is( 0, sslcheck( $mysync ), 'sslcheck: no host => 0' ) ; + + $mysync = { + sslcheck => 1, + host1 => 'test1.lamiral.info', + tls1 => 1, + } ; + + is( 0, sslcheck( $mysync ), 'sslcheck: tls1 => 0' ) ; + + $mysync = { + sslcheck => 1, + host1 => 'test1.lamiral.info', + } ; + + + is( 1, sslcheck( $mysync ), 'sslcheck: test1.lamiral.info => 1' ) ; + is( 1, $mysync->{ssl1}, 'sslcheck: test1.lamiral.info => ssl1 1' ) ; + + $mysync->{sslcheck} = 0 ; + is( undef, sslcheck( $mysync ), 'sslcheck: sslcheck off => undef' ) ; + + $mysync = { + sslcheck => 1, + host1 => 'test1.lamiral.info', + host2 => 'test2.lamiral.info', + } ; + + is( 2, sslcheck( $mysync ), 'sslcheck: test1.lamiral.info + test2.lamiral.info => 2' ) ; + + $mysync = { + sslcheck => 1, + host1 => 'test1.lamiral.info', + host2 => 'test2.lamiral.info', + tls1 => 1, + } ; + + is( 1, sslcheck( $mysync ), 'sslcheck: test1.lamiral.info + test2.lamiral.info + tls1 => 1' ) ; + + note( 'Leaving tests_sslcheck()' ) ; + return ; +} + +sub sslcheck +{ + my $mysync = shift @ARG ; + + if ( ! $mysync->{sslcheck} ) { + return ; + } + my $nb_on = 0 ; + $mysync->{ debug } and myprint( "sslcheck\n" ) ; + if ( + ( ! defined $mysync->{port1} ) + and + ( ! defined $mysync->{tls1} ) + and + ( ! defined $mysync->{ssl1} ) + and + ( defined $mysync->{host1} ) + ) { + myprint( "Host1: probing ssl on port $IMAP_SSL_PORT ( use --nosslcheck to avoid this ssl probe ) \n" ) ; + if ( probe_imapssl( $mysync->{host1} ) ) { + $mysync->{ssl1} = 1 ; + myprint( "Host1: sslcheck detected open ssl port $IMAP_SSL_PORT so turning ssl on (use --nossl1 --notls1 to turn off SSL and TLS wizardry)\n" ) ; + $nb_on++ ; + }else{ + myprint( "Host1: sslcheck did not detected open ssl port $IMAP_SSL_PORT. Will use standard $IMAP_PORT port.\n" ) ; + } + } + + if ( + ( ! defined $mysync->{port2} ) + and + ( ! defined $mysync->{tls2} ) + and + ( ! defined $mysync->{ssl2} ) + and + ( defined $mysync->{host2} ) + ) { + myprint( "Host2: probing ssl on port $IMAP_SSL_PORT ( use --nosslcheck to avoid this ssl probe ) \n" ) ; + if ( probe_imapssl( $mysync->{host2} ) ) { + $mysync->{ssl2} = 1 ; + myprint( "Host2: sslcheck detected open ssl port $IMAP_SSL_PORT so turning ssl on (use --nossl2 --notls2 to turn off SSL and TLS wizardry)\n" ) ; + $nb_on++ ; + }else{ + myprint( "Host2: sslcheck did not detected open ssl port $IMAP_SSL_PORT. Will use standard $IMAP_PORT port.\n" ) ; + } + } + return $nb_on ; +} + + +sub testslive_init +{ + my $mysync = shift @ARG ; + $mysync->{host1} ||= 'test1.lamiral.info' ; + $mysync->{user1} ||= 'test1' ; + $mysync->{password1} ||= 'secret1' ; + $mysync->{host2} ||= 'test2.lamiral.info' ; + $mysync->{user2} ||= 'test2' ; + $mysync->{password2} ||= 'secret2' ; + return ; +} + +sub testslive6_init +{ + my $mysync = shift @ARG ; + $mysync->{host1} ||= 'ks6ipv6.lamiral.info' ; + $mysync->{user1} ||= 'test1' ; + $mysync->{password1} ||= 'secret1' ; + $mysync->{host2} ||= 'ks6ipv6.lamiral.info' ; + $mysync->{user2} ||= 'test2' ; + $mysync->{password2} ||= 'secret2' ; + return ; +} + + +sub tests_backslash_caret +{ + note( 'Entering tests_backslash_caret()' ) ; + + is( "lalala", backslash_caret( "lalala" ), 'backslash_caret: lalala => lalala' ) ; + is( "lalala\n", backslash_caret( "lalala\n" ), 'backslash_caret: lalala => lalala 2nd' ) ; + is( '^', backslash_caret( '\\' ), 'backslash_caret: \\ => ^' ) ; + is( "^\n", backslash_caret( "\\\n" ), 'backslash_caret: \\ => ^' ) ; + is( "\\lalala", backslash_caret( "\\lalala" ), 'backslash_caret: \\lalala => \\lalala' ) ; + is( "\\lal\\ala", backslash_caret( "\\lal\\ala" ), 'backslash_caret: \\lal\\ala => \\lal\\ala' ) ; + is( "\\lalala\n", backslash_caret( "\\lalala\n" ), 'backslash_caret: \\lalala => \\lalala 2nd' ) ; + is( "lalala^\n", backslash_caret( "lalala\\\n" ), 'backslash_caret: lalala\\\n => lalala^\n' ) ; + is( "lalala^\nlalala^\n", backslash_caret( "lalala\\\nlalala\\\n" ), 'backslash_caret: lalala\\\nlalala\\\n => lalala^\nlalala^\n' ) ; + is( "lal\\ala^\nlalala^\n", backslash_caret( "lal\\ala\\\nlalala\\\n" ), 'backslash_caret: lal\\ala\\\nlalala\\\n => lal\\ala^\nlalala^\n' ) ; + + note( 'Leaving tests_backslash_caret()' ) ; + return ; +} + +sub backslash_caret +{ + my $string = shift @ARG ; + + $string =~ s{\\ $ }{^}gxms ; + + return $string ; +} + +sub tests_split_around_equal +{ + note( 'Entering tests_split_around_equal()' ) ; + + is( undef, split_around_equal( ), 'split_around_equal: no args => undef' ) ; + is_deeply( { toto => 'titi' }, { split_around_equal( 'toto=titi' ) }, 'split_around_equal: toto=titi => toto => titi' ) ; + is_deeply( { toto => undef }, { split_around_equal( 'toto' ) }, 'split_around_equal: tototiti => toto => undef' ) ; + is_deeply( { toto => '' }, { split_around_equal( 'toto=' ) }, 'split_around_equal: tototiti => toto= => empty' ) ; + is_deeply( { A => 'B', C => 'D' }, { split_around_equal( 'A=B', 'C=D' ) }, 'split_around_equal: A=B C=D => A => B, C=>D' ) ; + is_deeply( { A => 'B', C => 'D', E => 'F' }, { split_around_equal( 'A=B', 'C=D', 'E=F' ) }, 'split_around_equal: A=B C=D => A => B, C=>D' ) ; + is_deeply( { A => 'B=C' }, { split_around_equal( 'A=B=C' ) }, 'split_around_equal: A=B=C => A => B=C' ) ; + is_deeply( { A => 'B=C=D' }, { split_around_equal( 'A=B=C=D' ) }, 'split_around_equal: A=B=C=D => A => B=C=D' ) ; + + note( 'Leaving tests_split_around_equal()' ) ; + return ; +} + +sub split_around_equal +{ + if ( ! @ARG ) { return ; } ; + return map { split( /=/mxs, $_, 2 ) } @ARG ; + +} + + + +sub tests_sig_install +{ + note( 'Entering tests_sig_install()' ) ; + + my $mysync ; + is( undef, sig_install( ), 'sig_install: no args => undef' ) ; + is( undef, sig_install( $mysync ), 'sig_install: arg undef => undef' ) ; + $mysync = { } ; + is( undef, sig_install( $mysync ), 'sig_install: empty hash => undef' ) ; + + SKIP: { + Readonly my $SKIP_15 => 15 ; + if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests only for Unix', $SKIP_15 ) ; } + # Default to ignore USR1 USR2 in case future install fails + local $SIG{ USR1 } = local $SIG{ USR2 } = sub { } ; + kill( 'USR1', $PROCESS_ID ) ; + + $mysync->{ debugsig } = 1 ; + # Assign USR1 to call sub tototo + # Surely a better value than undef should be returned when doing real signal stuff + is( undef, sig_install( $mysync, 'tototo', 'USR1' ), 'sig_install: USR1 tototo' ) ; + + is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 1' ) ; + is( 1, $mysync->{ tototo_calls }, 'sig_install: tototo call nb 1' ) ; + + #return ; + # Assign USR2 to call sub tototo + is( undef, sig_install( $mysync, 'tototo', 'USR2' ), 'sig_install: USR2 tototo' ) ; + + is( 1, kill( 'USR2', $PROCESS_ID ), 'sig_install: kill USR2 myself 1' ) ; + is( 2, $mysync->{ tototo_calls }, 'sig_install: tototo call nb 2' ) ; + + is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 2' ) ; + is( 3, $mysync->{ tototo_calls }, 'sig_install: tototo call nb 3' ) ; + + + local $SIG{ USR1 } = local $SIG{ USR2 } = sub { } ; + is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 3' ) ; + is( 3, $mysync->{ tototo_calls }, 'sig_install: tototo call still nb 3' ) ; + + # Assign USR1 + USR2 to call sub tototo + is( undef, sig_install( $mysync, 'tototo', 'USR1', 'USR2' ), 'sig_install: USR1 USR2 tototo' ) ; + is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 4' ) ; + is( 4, $mysync->{ tototo_calls }, 'sig_install: tototo call now nb 4' ) ; + + is( 1, kill( 'USR2', $PROCESS_ID ), 'sig_install: kill USR1 myself 2' ) ; + is( 5, $mysync->{ tototo_calls }, 'sig_install: tototo call now nb 5' ) ; + } + + + note( 'Leaving tests_sig_install()' ) ; + return ; +} + + +# +sub sig_install +{ + my $mysync = shift @ARG ; + if ( ! $mysync ) { return ; } + my $mysubname = shift @ARG ; + if ( ! $mysubname ) { return ; } + + if ( ! @ARG ) { return ; } + + my @signals = @ARG ; + + my $mysub = \&$mysubname ; + #$mysync->{ debugsig } = 1 ; + $mysync->{ debugsig } and myprint( "In sig_install with sub $mysubname and signal @ARG\n" ) ; + + my $subsignal = sub { + my $signame = shift @ARG ; + $mysync->{ debugsig } and myprint( "In subsignal with $signame and $mysubname\n" ) ; + &$mysub( $mysync, $signame ) ; + } ; + + foreach my $signal ( @signals ) { + $mysync->{ debugsig } and myprint( "Installing signal $signal to call sub $mysubname\n") ; + output( $mysync, "kill -$signal $PROCESS_ID # special behavior: call to sub $mysubname\n" ) ; + ## no critic (RequireLocalizedPunctuationVars) + $SIG{ $signal } = $subsignal ; + } + return ; +} + + +sub tototo +{ + my $mysync = shift @ARG ; + myprint("In tototo with @ARG\n" ) ; + $mysync->{ tototo_calls } += 1 ; + return ; +} + +sub mygetppid +{ + if ( 'MSWin32' eq $OSNAME ) { + return( 'unknown under MSWin32 (too complicated)' ) ; + } else { + # Unix + return( getppid( ) ) ; + } +} + + +sub tests_toggle_sleep +{ + note( 'Entering tests_toggle_sleep()' ) ; + + is( undef, toggle_sleep( ), 'toggle_sleep: no args => undef' ) ; + my $mysync ; + is( undef, toggle_sleep( $mysync ), 'toggle_sleep: undef => undef' ) ; + $mysync = { } ; + is( undef, toggle_sleep( $mysync ), 'toggle_sleep: no maxsleep => undef' ) ; + + $mysync->{maxsleep} = 3 ; + is( 0, toggle_sleep( $mysync ), 'toggle_sleep: 3 => 0' ) ; + + is( $MAX_SLEEP, toggle_sleep( $mysync ), "toggle_sleep: 0 => $MAX_SLEEP" ) ; + is( 0, toggle_sleep( $mysync ), "toggle_sleep: $MAX_SLEEP => 0" ) ; + is( $MAX_SLEEP, toggle_sleep( $mysync ), "toggle_sleep: 0 => $MAX_SLEEP" ) ; + is( 0, toggle_sleep( $mysync ), "toggle_sleep: $MAX_SLEEP => 0" ) ; + + SKIP: { + Readonly my $SKIP_9 => 9 ; + if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests only for Unix', $SKIP_9 ) ; } + # Default to ignore USR1 USR2 in case future install fails + local $SIG{ USR1 } = sub { } ; + kill( 'USR1', $PROCESS_ID ) ; + + $mysync->{ debugsig } = 1 ; + # Assign USR1 to call sub toggle_sleep + is( undef, sig_install( $mysync, \&toggle_sleep, 'USR1' ), 'toggle_sleep: install USR1 toggle_sleep' ) ; + + + $mysync->{maxsleep} = 4 ; + is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself' ) ; + is( 0, $mysync->{ maxsleep }, 'toggle_sleep: toggle_sleep called => sleeps are 0s' ) ; + + is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself again' ) ; + is( $MAX_SLEEP, $mysync->{ maxsleep }, "toggle_sleep: toggle_sleep called => sleeps are ${MAX_SLEEP}s" ) ; + + is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself' ) ; + is( 0, $mysync->{ maxsleep }, 'toggle_sleep: toggle_sleep called => sleeps are 0s' ) ; + + is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself again' ) ; + is( $MAX_SLEEP, $mysync->{ maxsleep }, "toggle_sleep: toggle_sleep called => sleeps are ${MAX_SLEEP}s" ) ; + } + + note( 'Leaving tests_toggle_sleep()' ) ; + return ; +} + + +sub toggle_sleep +{ + my $mysync = shift @ARG ; + + myprint("In toggle_sleep with @ARG\n" ) ; + + if ( !defined( $mysync ) ) { return ; } + if ( !defined( $mysync->{maxsleep} ) ) { return ; } + + $mysync->{ maxsleep } = max( 0, $MAX_SLEEP - $mysync->{maxsleep} ) ; + myprint("Resetting maxsleep to ", $mysync->{maxsleep}, "s\n" ) ; + return $mysync->{maxsleep} ; +} + +sub mypod2usage +{ + my $fh_pod2usage = shift @ARG ; + + pod2usage( + -exitval => 'NOEXIT', + -noperldoc => 1, + -verbose => 99, + -sections => [ qw(NAME VERSION USAGE OPTIONS) ], + -indent => 1, + -loose => 1, + -output => $fh_pod2usage, + ) ; + + return ; +} + +sub usage +{ + my $mysync = shift @ARG ; + + if ( ! defined $mysync ) { return ; } + + my $usage = q{} ; + my $usage_from_pod ; + my $usage_footer = usage_footer( $mysync ) ; + + # pod2usage writes on a filehandle only and I want a variable + open my $fh_pod2usage, ">", \$usage_from_pod + or do { warn $OS_ERROR ; return ; } ; + mypod2usage( $fh_pod2usage ) ; + close $fh_pod2usage ; + + if ( 'MSWin32' eq $OSNAME ) { + $usage_from_pod = backslash_caret( $usage_from_pod ) ; + } + $usage = join( q{}, $usage_from_pod, $usage_footer ) ; + + return( $usage ) ; +} + +sub tests_usage +{ + note( 'Entering tests_usage()' ) ; + + my $usage ; + like( $usage = usage( $sync ), qr/Name:/, 'usage: contains Name:' ) ; + myprint( $usage ) ; + like( $usage, qr/Version:/, 'usage: contains Version:' ) ; + like( $usage, qr/Usage:/, 'usage: contains Usage:' ) ; + like( $usage, qr/imapsync/, 'usage: contains imapsync' ) ; + + is( undef, usage( ), 'usage: no args => undef' ) ; + + note( 'Leaving tests_usage()' ) ; + return ; +} + + +sub usage_footer +{ + my $mysync = shift @ARG ; + + my $footer = q{} ; + + my $localhost_info = localhost_info( $mysync ) ; + my $rcs = $mysync->{rcs} ; + my $homepage = homepage( ) ; + + my $imapsync_release = $STR_use_releasecheck ; + + if ( $mysync->{releasecheck} ) { + $imapsync_release = check_last_release( ) ; + } + + $footer = qq{$localhost_info +$rcs +$imapsync_release +$homepage +} ; + return( $footer ) ; +} + + + +sub usage_complete +{ + # Unused, I guess this function could be deleted + my $usage = <<'EOF' ; +--skipheader reg : Don't take into account header keyword + matching reg ex: --skipheader 'X.*' + +--skipsize : Don't take message size into account to compare + messages on both sides. On by default. + Use --no-skipsize for using size comparaison. +--allowsizemismatch : allow RFC822.SIZE != fetched msg size + consider also --skipsize to avoid duplicate messages + when running syncs more than one time per mailbox + +--reconnectretry1 int : reconnect to host1 if connection is lost up to + int times per imap command (default is 3) +--reconnectretry2 int : same as --reconnectretry1 but for host2 +--split1 int : split the requests in several parts on host1. + int is the number of messages handled per request. + default is like --split1 100. +--split2 int : same thing on host2. +--nofixInboxINBOX : Don't fix Inbox INBOX mapping. +EOF + return( $usage ) ; +} + + + + +sub setvalfromcgikey +{ + my ( $mysync, $mycgi, $key, $val ) = @ARG ; + + my $badthings = 0 ; + + + my ( $name, $type, $struct ) ; + if ( $key !~ m/^([\w\d\|]+)([=:][isf])?([\+!\@\%])?$/mxs ) + { + $badthings++ ; + next ; # Unknown item + } + else + { + $name = [ split '|', $1, 1 ]->[0] ; # option name ab|cd|ef => keep only ab + $type = $2 ; # = or : followed by i or s or f + $struct = $3 ; # + or ! or @ or % + } + + if ( ( $struct || q{} ) eq '+' ) + { + ${$val} = $mycgi->param( $name ) ; # "Incremental" integer + } + elsif ( $type ) + { + my @values = $mycgi->multi_param( $name ) ; + + #myprint( "type[$type]values[@values]\$struct[", $struct || q{}, "]val[$val]ref(val)[", ref($val), "]\n" ) ; + if ( ( $struct || q{} ) eq '%' or ref( $val ) eq 'HASH' ) + { + setvalfromhash( $val, $type, @values ) ; + } + else + { + setvalfromlist( $mysync, $val, $name, $type, $struct, @values ) ; + } + } + else + { + setvalfromcheckbox( $mysync, $mycgi, $key, $name, $val ) ; + } + + return $badthings ; +} + +sub setvalfromlist +{ + my ( $mysync, $val, $name, $type, $struct, @values ) = @ARG ; + if ( $type =~ m/i$/mxs ) + { + @values = map { q{} ne $_ ? int $_ : undef } @values ; + } + elsif ( $type =~ m/f$/mxs ) + { + @values = map { 0 + $_ } @values ; + } + + if ( ( $struct || q{} ) eq '@' ) + { + @{ ${$val} } = @values ; + my @option = map { +( "--$name", "$_" ) } @values ; + push @{ $mysync->{ cmdcgi } }, @option ; + } + elsif ( ref( $val ) eq 'ARRAY' ) + { + @{$val} = @values ; + } + elsif ( my $value = $values[0] ) + { + ${$val} = $value ; + push @{ $mysync->{ cmdcgi } }, "--$name", $value ; + } + else + { + } + + return ; +} +sub setvalfromhash +{ + my ( $val, $type, @values ) = @ARG ; + + my %values = map { split /=/mxs, $_ } @values ; + + if ( $type =~ m/i$/mxs ) + { + foreach my $k ( keys %values ) + { + $values{$k} = int $values{$k} ; + } + } + elsif ( $type =~ m/f$/mxs ) + { + foreach my $k ( keys %values ) { + $values{$k} = 0 + $values{$k}; + } + } + + if ( 'REF' eq ref $val ) + { + %{ ${$val} } = %values ; + } + else + { + %{$val} = %values ; + } + + return ; +} + + +sub setvalfromcheckbox +{ + my ( $mysync, $mycgi, $key, $name, $val ) = @ARG ; + + # Checkbox + # --noname is set by name=0 or name= + my $value = $mycgi->param( $name ) ; + if ( defined $value ) + { + ${$val} = $value ; + if ( $value ) + { + push @{ $mysync->{ cmdcgi } }, "--$name" ; + } + else + { + push @{ $mysync->{ cmdcgi } }, "--no$name" ; + } + } + else + { + ${$val} = undef ; + } + return ; +} + +sub myGetOptions +{ + + # Started as a copy of Luke Ross Getopt::Long::CGI + # https://metacpan.org/release/Getopt-Long-CGI + # So this sub function is under the same license as Getopt-Long-CGI Luke Ross wants it, + # which was Perl 5.6 or later licenses at the date of the copy. + # It also applies for the sub functions called from this one. + + my $mysync = shift @ARG ; + my $arguments_ref = shift @ARG ; + my %options = @ARG ; + + my $mycgi = $mysync->{cgi} ; + + if ( not under_cgi_context() ) { + + # Not CGI - pass upstream for normal command line handling + return Getopt::Long::GetOptionsFromArray( $arguments_ref, %options ) ; + } + + # We must be in CGI context now + if ( ! defined( $mycgi ) ) { return ; } + + my $badthings = 0 ; + foreach my $key ( sort keys %options ) { + my $val = $options{$key} ; + + $badthings += setvalfromcgikey( $mysync, $mycgi, $key, $val ) ; + + } + + if ( $badthings ) { + return ; # undef or () + } + else { + return ( 1 ) ; + } +} + + + +sub tests_get_options_extra +{ + note( 'Entering tests_get_options_extra()' ) ; + + is( undef, get_options_extra( ), 'get_options_extra: no args => undef' ) ; + + my $mysync = { } ; + is( undef, get_options_extra( $mysync ), 'get_options_extra: undef => undef' ) ; + + my $cwd_save = getcwd( ) ; + + ok( (-d 'W/tmp/tests/options_extra/' or mkpath( 'W/tmp/tests/options_extra/' )), 'get_options_extra: mkpath W/tmp/tests/options_extra/' ) ; + + chdir 'W/tmp/tests/options_extra/' ; + + is( '--debugimap1', string_to_file( '--debugimap1', 'options_extra.txt' ), 'get_options_extra: string_to_file filling options_extra.txt with --debugimap1' ) ; + + is( '--debugimap1', file_to_string( 'options_extra.txt' ), 'get_options_extra: reading options_extra.txt is --debugimap1' ) ; + + is( '', get_options_extra( $mysync ), 'get_options_extra: --debugimap1 in options_extra.txt => nothing left, empty string return' ) ; + + is( 1, $mysync->{ acc1 }->{ debugimap }, 'get_options_extra: --debugimap1 in options_extra.txt => ok, acc1->debugimap = 1' ) ; + + is( '--tls1 proutcaca', string_to_file( '--tls1 proutcaca', 'options_extra.txt' ), 'get_options_extra: string_to_file filling options_extra.txt with --tls1 proutcaca' ) ; + + is( 'proutcaca', get_options_extra( $mysync ), 'get_options_extra: --tls1 proutcaca in options_extra.txt => proutcaca left, proutcaca return' ) ; + + chdir $cwd_save ; + + note( 'Leaving tests_get_options_extra()' ) ; + return ; +} + +sub get_options_extra +{ + my $mysync = shift @ARG ; + + if ( ! defined $mysync ) { return ; } + + if ( -f -r 'options_extra.txt' ) + { + my $cwd = getcwd( ) ; + my $string = firstline( 'options_extra.txt' ) ; + my $rest = get_options_from_string( $mysync, $string ) ; + output( $mysync, "Reading extra options from file options_extra.txt (cwd: $cwd) : $string\n" ) ; + return $rest ; + } + else + { + return ; + } +} + + +sub tests_get_options_from_string +{ + note( 'Entering tests_get_options_from_string()' ) ; + + is( undef, get_options_from_string( ), 'get_options_from_string: no args => undef' ) ; + my $mysync = { } ; + is( undef, get_options_from_string( $mysync ), 'get_options_from_string: undef => undef' ) ; + + is( '', get_options_from_string( $mysync, '--debugimap1' ), + 'get_options_from_string: --debugimap1 => ok, nothing left, empty string return' ) ; + is( 1, $mysync->{ acc1 }->{ debugimap }, 'get_options_from_string: --debugimap1 => ok, acc1->debugimap = 1' ) ; + + $mysync = { } ; # reset + is( 'caca', get_options_from_string( $mysync, '--debugimap1 caca' ), + 'get_options_from_string: --debugimap1 caca => ok, caca left, caca return' ) ; + is( 1, $mysync->{ acc1 }->{ debugimap }, 'get_options_from_string: --debugimap1 => ok, acc1->debugimap = 1' ) ; + + is( 'popo roro', get_options_from_string( $mysync, '--debugimap2 popo roro' ), + 'get_options_from_string: --debugimap1 popo roro => ok, popo roro left, popo roro return' ) ; + is( 1, $mysync->{ acc2 }->{ debugimap }, 'get_options_from_string: --debugimap2 popo roro => ok, acc2->debugimap = 1' ) ; + is( 1, $mysync->{ acc1 }->{ debugimap }, 'get_options_from_string: acc1->debugimap = 1 still' ) ; + + is( '', get_options_from_string( $mysync, '--nodebugimap1 --debugflags --errorsmax 2' ), + 'get_options_from_string: --nodebugimap1 --debugflags --errorsmax 2 => ok, empty string return' ) ; + + is( 0, $mysync->{ acc1 }->{ debugimap }, 'get_options_from_string: acc1->debugimap = 0 now' ) ; + is( 1, $mysync->{ debugflags }, 'get_options_from_string: debugflags = 1 now' ) ; + is( 2, $mysync->{ errorsmax }, 'get_options_from_string: mysync->errorsmax = 2 now' ) ; + + is( '', get_options_from_string( $mysync, '--folder "IN BOX" --folder JOE' ), + 'get_options_from_string: --folder "IN BOX" --folder JOE => ok, empty string return' ) ; + + is_deeply( [ 'IN BOX', 'JOE' ], [@{$mysync->{ folder }}], 'get_options_from_string: "IN BOX" "JOE"' ) ; + + is( '', get_options_from_string( $mysync, '--debugflags --koko' ), + 'get_options_from_string: --debugflags --koko => ok, empty string return, with "Unknown option: koko" on STDERR' ) ; + + note( 'Leaving tests_get_options_from_string()' ) ; + return ; +} + +sub get_options_from_string +{ + my $mysync = shift @ARG ; + my $mystring = shift @ARG ; + + if ( ! defined $mystring ) { return ; } + + my ( $ret, $args ) = Getopt::Long::GetOptionsFromString( $mystring, + 'debugimap!' => \$mysync->{ debugimap }, + 'debugimap1!' => \$mysync->{ acc1 }->{ debugimap }, + 'debugimap2!' => \$mysync->{ acc2 }->{ debugimap }, + 'debugflags!' => \$mysync->{ debugflags }, + 'debugsleep=f' => \$mysync->{ debugsleep }, + 'errorsmax=i' => \$mysync->{ errorsmax }, + 'folder=s@' => \$mysync->{ folder }, + 'timeout=f' => \$mysync->{ timeout }, + 'timeout1=f' => \$mysync->{ acc1 }->{ timeout }, + 'timeout2=f' => \$mysync->{ acc2 }->{ timeout }, + 'keepalive1!' => \$mysync->{ acc1 }->{ keepalive }, + 'keepalive2!' => \$mysync->{ acc2 }->{ keepalive }, + 'reconnectretry1=i' => \$mysync->{ acc1 }->{ reconnectretry }, + 'reconnectretry2=i' => \$mysync->{ acc2 }->{ reconnectretry }, + 'ssl1!' => \$mysync->{ ssl1 }, + 'ssl2!' => \$mysync->{ ssl2 }, + 'tls1!' => \$mysync->{ tls1 }, + 'tls2!' => \$mysync->{ tls2 }, + 'compress1!' => \$mysync->{ acc1 }->{ compress }, + 'compress2!' => \$mysync->{ acc2 }->{ compress }, + ) ; + my $left = join( ' ', @$args ) ; + return $left ; +} + + + + + + +sub tests_get_options_cgi_context +{ + note( 'Entering tests_get_options_cgi_context()' ) ; + + +# Temporary, have to think harder about testing CGI context in command line --tests + # API: + # * input arguments: two ways, command line or CGI + # * the program arguments + # * QUERY_STRING env variable + # * return + # * QUERY_STRING length + + # CGI context + local $ENV{SERVER_SOFTWARE} = 'Votre serviteur' ; + + # Real full test + # = 'host1=test1.lamiral.info&user1=test1&password1=secret1&host2=test2.lamiral.info&user2=test2&password2=secret2&debugenv=on' + my $mysync ; + is( undef, get_options( $mysync ), 'get_options cgi context: no CGI module => undef' ) ; + + # skip all next tests if the CGI module is not available + + SKIP: { + if ( ! eval { require CGI ; } ) { + skip( "CGI Perl module is not installed", 19 ) ; + } + + CGI->import( qw( -no_debug -utf8 ) ) ; + + is( undef, get_options( $mysync ), 'get_options cgi context: no CGI param => undef' ) ; + # Testing boolean + $mysync->{cgi} = CGI->new( 'version=on&debugenv=on' ) ; + local $ENV{'QUERY_STRING'} = 'version=on&debugenv=on' ; + is( 22, get_options( $mysync ), 'get_options cgi context: QUERY_STRING => 22' ) ; + is( 'on', $mysync->{ version }, 'get_options cgi context: --version => on' ) ; + # debugenv is not allowed in cgi context + is( undef, $mysync->{debugenv}, 'get_options cgi context: $mysync->{debugenv} => undef' ) ; + + # QUERY_STRING in this test is only for return value of get_options + # Have to think harder, GET/POST context, is this return value a good thing? + local $ENV{'QUERY_STRING'} = 'host1=test1.lamiral.info&user1=test1' ; + $mysync->{cgi} = CGI->new( 'host1=test1.lamiral.info&user1=test1' ) ; + is( 36, get_options( $mysync, ), 'get_options cgi context: QUERY_STRING => 36' ) ; + is( 'test1', $mysync->{user1}, 'get_options cgi context: $mysync->{user1} => test1' ) ; + #local $ENV{'QUERY_STRING'} = undef ; + + # Testing s@ as ref + $mysync->{cgi} = CGI->new( 'folder=fd1' ) ; + get_options( $mysync ) ; + is_deeply( [ 'fd1' ], $mysync->{ folder }, 'get_options cgi context: $mysync->{ folder } => fd1' ) ; + $mysync->{cgi} = CGI->new( 'folder=fd1&folder=fd2' ) ; + get_options( $mysync ) ; + is_deeply( [ 'fd1', 'fd2' ], $mysync->{ folder }, 'get_options cgi context: $mysync->{ folder } => fd1, fd2' ) ; + + # Testing % + $mysync->{cgi} = CGI->new( 'f1f2h=s1=d1&f1f2h=s2=d2&f1f2h=s3=d3' ) ; + get_options( $mysync ) ; + + is_deeply( { 's1' => 'd1', 's2' => 'd2', 's3' => 'd3' }, + $mysync->{f1f2h}, 'get_options cgi context: f1f2h => s1=d1 s2=d2 s3=d3' ) ; + + # Testing boolean ! with --noxxx, doesnot work + $mysync->{cgi} = CGI->new( 'nodry=on' ) ; + get_options( $mysync ) ; + is( undef, $mysync->{dry}, 'get_options cgi context: --nodry => $mysync->{dry} => undef' ) ; + + $mysync->{cgi} = CGI->new( 'host1=example.com' ) ; + get_options( $mysync ) ; + is( 'example.com', $mysync->{host1}, 'get_options cgi context: --host1=example.com => $mysync->{host1} => example.com' ) ; + + #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; + $mysync->{cgi} = CGI->new( 'simulong=' ) ; + get_options( $mysync ) ; + is( undef, $mysync->{simulong}, 'get_options cgi context: --simulong= => $mysync->{simulong} => undef' ) ; + + $mysync->{cgi} = CGI->new( 'simulong' ) ; + get_options( $mysync ) ; + is( undef, $mysync->{simulong}, 'get_options cgi context: --simulong => $mysync->{simulong} => undef' ) ; + + $mysync->{cgi} = CGI->new( 'simulong=4' ) ; + get_options( $mysync ) ; + is( 4, $mysync->{simulong}, 'get_options cgi context: --simulong=4 => $mysync->{simulong} => 4' ) ; + is( undef, $mysync->{ folder }, 'get_options cgi context: --simulong=4 => $mysync->{ folder } => undef' ) ; + #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; + + $mysync ={} ; + $mysync->{cgi} = CGI->new( 'testslive=on' ) ; + get_options( $mysync ) ; + is( 'on', $mysync->{ testslive }, 'get_options cgi context: --testslive=on => testslive => on' ) ; + #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; + + $mysync ={} ; + $mysync->{cgi} = CGI->new( 'log=0' ) ; + get_options( $mysync ) ; + is( 0, $mysync->{ log }, 'get_options cgi context: --log=0 => log => 0' ) ; + #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; + + + # What is this fucked up indentation? + } + + + note( 'Leaving tests_get_options_cgi_context()' ) ; + return ; +} + + + +sub get_options_cgi +{ + # In CGI context arguments are not in @ARGV but in QUERY_STRING variable (with GET). + my $mysync = shift @ARG ; + $mysync->{cgi} || return ; + my @arguments = @ARG ; + # final 0 is used to print usage when no option is given + my $numopt = length $ENV{'QUERY_STRING'} || 1 ; + $mysync->{f1f2h} = {} ; + my $opt_ret = myGetOptions( + $mysync, + \@arguments, + 'abort' => \$mysync->{ abort }, + 'abortbyfile' => \$mysync->{ abortbyfile }, + 'host1=s' => \$mysync->{ host1 }, + 'host2=s' => \$mysync->{ host2 }, + 'user1=s' => \$mysync->{ user1 }, + 'user2=s' => \$mysync->{ user2 }, + 'password1=s' => \$mysync->{ password1 }, + 'password2=s' => \$mysync->{ password2 }, + 'dry!' => \$mysync->{ dry }, + 'dry1!' => \$mysync->{ dry1 }, + 'version' => \$mysync->{ version }, + 'ssl1!' => \$mysync->{ ssl1 }, + 'ssl2!' => \$mysync->{ ssl2 }, + 'tls1!' => \$mysync->{ tls1 }, + 'tls2!' => \$mysync->{ tls2 }, + 'compress1!' => \$mysync->{ acc1 }->{ compress }, + 'compress2!' => \$mysync->{ acc2 }->{ compress }, + 'justbanner!' => \$mysync->{ justbanner }, + 'justlogin!' => \$mysync->{ justlogin }, + 'justconnect!' => \$mysync->{ justconnect }, + 'addheader!' => \$mysync->{ addheader }, + 'automap!' => \$mysync->{ automap }, + 'justautomap!' => \$mysync->{ justautomap }, + 'gmail1' => \$mysync->{ gmail1 }, + 'gmail2' => \$mysync->{ gmail2 }, + 'office1' => \$mysync->{ office1 }, + 'office2' => \$mysync->{ office2 }, + 'exchange1' => \$mysync->{ exchange1 }, + 'exchange2' => \$mysync->{ exchange2 }, + 'domino1' => \$mysync->{ domino1 }, + 'domino2' => \$mysync->{ domino2 }, + 'f1f2=s@' => \$mysync->{ f1f2 }, + 'f1f2h=s%' => \$mysync->{ f1f2h }, + 'folder=s@' => \$mysync->{ folder }, + 'testslive!' => \$mysync->{ testslive }, + 'testslive6!' => \$mysync->{ testslive6 }, + 'releasecheck!' => \$mysync->{ releasecheck }, + 'simulong=f' => \$mysync->{ simulong }, + 'debugsleep=f' => \$mysync->{ debugsleep }, + 'subfolder1=s' => \$mysync->{ subfolder1 }, + 'subfolder2=s' => \$mysync->{ subfolder2 }, + 'justfolders!' => \$mysync->{ justfolders }, + 'justfoldersizes!' => \$mysync->{ justfoldersizes }, + 'delete1!' => \$mysync->{ delete1 }, + 'delete2!' => \$mysync->{ delete2 }, + 'delete2duplicates!' => \$mysync->{ delete2duplicates }, + 'tail!' => \$mysync->{ tail }, + 'tmphash=s' => \$mysync->{ tmphash }, + 'exitwhenover=i' => \$mysync->{ exitwhenover }, + 'exitonload!' => \$mysync->{ exitonload }, + 'syncduplicates!' => \$mysync->{ syncduplicates }, + 'skipcrossduplicates!' => \$mysync->{ skipcrossduplicates }, + 'debugcrossduplicates!'=> \$mysync->{ debugcrossduplicates }, + 'log!' => \$mysync->{ log }, + 'loglogfile!' => \$mysync->{ loglogfile }, + 'emailreportfrom=s' => \$mysync->{ email_report_from }, + 'emailreport1!' => \$mysync->{ emailreport1 }, + 'emailreport2!' => \$mysync->{ emailreport2 }, + 'var=s@' => \$mysync->{ var }, + +# f1f2h=s% could be removed but +# tests_get_options_cgi() should be split before +# with a sub tests_myGetOptions() + ) ; + + $mysync->{ debug } and output( $mysync, "get options: [$opt_ret][$numopt]\n" ) ; + + if ( ! $opt_ret ) { + return ; + } + return $numopt ; +} + +sub get_options_cmd +{ + my $mysync = shift @ARG ; + my @arguments = @ARG ; + my $mycgi = $mysync->{cgi} ; + # final 0 is used to print usage when no option is given on command line + my $numopt = scalar @arguments || 0 ; + my $argv = join "\x00", @arguments ; + + if ( $argv =~ m/-delete\x002/x ) { + output( $mysync, "May be you mean --delete2 instead of --delete 2\n" ) ; + return ; + } + $mysync->{f1f2h} = {} ; + my $opt_ret = myGetOptions( + $mysync, + \@arguments, + 'debug!' => \$mysync->{ debug }, + 'debuglist!' => \$mysync->{ debuglist }, + 'debugcontent!' => \$mysync->{ debugcontent }, + 'debugsleep=f' => \$mysync->{ debugsleep }, + 'debugflags!' => \$mysync->{ debugflags }, + 'debugimap!' => \$mysync->{ debugimap }, + 'debugimap1!' => \$mysync->{ acc1 }->{ debugimap }, + 'debugimap2!' => \$mysync->{ acc2 }->{ debugimap }, + 'debugdev!' => \$debugdev, + 'debugmemory!' => \$mysync->{debugmemory}, + 'debugfolders!' => \$mysync->{debugfolders}, + 'debugssl=i' => \$mysync->{debugssl}, + 'debugcgi!' => \$debugcgi, + 'debugenv!' => \$mysync->{debugenv}, + 'debugsig!' => \$mysync->{debugsig}, + 'debuglabels!' => \$mysync->{debuglabels}, + + 'simulong=f' => \$mysync->{simulong}, + 'abort' => \$mysync->{abort}, + 'abortbyfile' => \$mysync->{abortbyfile}, + + 'host1=s' => \$mysync->{ host1 }, + 'host2=s' => \$mysync->{ host2 }, + 'port1=i' => \$mysync->{ port1 }, + 'port2=i' => \$mysync->{ port2 }, + 'inet4|ipv4' => \$mysync->{ inet4 }, + 'inet6|ipv6' => \$mysync->{ inet6 }, + 'user1=s' => \$mysync->{ user1 }, + 'user2=s' => \$mysync->{ user2 }, + 'gmail1' => \$mysync->{gmail1}, + 'gmail2' => \$mysync->{gmail2}, + 'office1' => \$mysync->{office1}, + 'office2' => \$mysync->{office2}, + 'exchange1' => \$mysync->{exchange1}, + 'exchange2' => \$mysync->{exchange2}, + 'domino1' => \$mysync->{domino1}, + 'domino2' => \$mysync->{domino2}, + 'domain1=s' => \$mysync->{ acc1 }->{ domain }, + 'domain2=s' => \$mysync->{ acc2 }->{ domain }, + 'password1=s' => \$mysync->{password1}, + 'password2=s' => \$mysync->{password2}, + 'passfile1=s' => \$mysync->{ passfile1 }, + 'passfile2=s' => \$mysync->{ passfile2 }, + 'authmd5!' => \$authmd5, + 'authmd51!' => \$authmd51, + 'authmd52!' => \$authmd52, + + 'trylogin!' => \$mysync->{ trylogin }, + + 'oauthdirect1=s' => \$mysync->{ acc1 }->{ oauthdirect }, + 'oauthdirect2=s' => \$mysync->{ acc2 }->{ oauthdirect }, + + 'oauthaccesstoken1=s' => \$mysync->{ acc1 }->{ oauthaccesstoken }, + 'oauthaccesstoken2=s' => \$mysync->{ acc2 }->{ oauthaccesstoken }, + + 'sep1=s' => \$mysync->{ sep1 }, + 'sep2=s' => \$mysync->{ sep2 }, + 'sanitize!' => \$mysync->{ sanitize }, + 'folder=s@' => \$mysync->{ folder }, + 'folderrec=s' => \@folderrec, + 'include=s' => \@include, + 'exclude=s' => \@exclude, + 'noexclude' => \$mysync->{noexclude}, + 'folderfirst=s' => \@folderfirst, + 'folderlast=s' => \@folderlast, + 'prefix1=s' => \$prefix1, + 'prefix2=s' => \$prefix2, + 'subfolder1=s' => \$mysync->{ subfolder1 }, + 'subfolder2=s' => \$mysync->{ subfolder2 }, + 'fixslash2!' => \$mysync->{ fixslash2 }, + 'fixInboxINBOX!' => \$fixInboxINBOX, + 'regextrans2=s@' => \$mysync->{ regextrans2 }, + 'mixfolders!' => \$mixfolders, + 'skipemptyfolders!' => \$mysync->{ skipemptyfolders }, + 'regexmess=s' => \@regexmess, + 'noregexmess' => \$mysync->{noregexmess}, + 'skipmess=s' => \@skipmess, + 'pipemess=s' => \@pipemess, + 'pipemesscheck!' => \$pipemesscheck, + 'disarmreadreceipts!' => \$disarmreadreceipts, + 'regexflag=s@' => \$mysync->{ regexflag }, + 'noregexflag' => \$mysync->{ noregexflag }, + 'filterflags!' => \$mysync->{ filterflags }, + 'filterbuggyflags!' => \$mysync->{ filterbuggyflags }, + 'flagscase!' => \$mysync->{ flagscase }, + 'syncflagsaftercopy!' => \$syncflagsaftercopy, + 'resyncflags!' => \$mysync->{ resyncflags }, + 'synclabels!' => \$mysync->{ synclabels }, + 'resynclabels!' => \$mysync->{ resynclabels }, + 'delete|delete1!' => \$mysync->{ delete1 }, + 'delete2!' => \$mysync->{ delete2 }, + 'delete2duplicates!' => \$mysync->{ delete2duplicates }, + 'delete2folders!' => \$delete2folders, + 'delete2foldersonly=s' => \$delete2foldersonly, + 'delete2foldersbutnot=s' => \$delete2foldersbutnot, + 'syncinternaldates!' => \$syncinternaldates, + 'idatefromheader!' => \$idatefromheader, + 'syncacls!' => \$mysync->{ syncacls }, + 'maxsize=i' => \$mysync->{ maxsize }, + 'appendlimit=i' => \$mysync->{ appendlimit }, + 'truncmess=i' => \$mysync->{ truncmess }, + 'minsize=i' => \$minsize, + 'maxage=f' => \$maxage, + 'minage=f' => \$minage, + 'search=s' => \$search, + 'search1=s' => \$mysync->{ search1 }, + 'search2=s' => \$mysync->{ search2 }, + 'foldersizes!' => \$mysync->{ foldersizes }, + 'foldersizesatend!' => \$mysync->{ foldersizesatend }, + 'dry!' => \$mysync->{dry}, + 'dry1!' => \$mysync->{dry1}, + 'expunge1|expunge!' => \$mysync->{ expunge1 }, + 'expunge2!' => \$mysync->{ expunge2 }, + 'uidexpunge2!' => \$mysync->{ uidexpunge2 }, + 'subscribed' => \$subscribed, + 'subscribe!' => \$subscribe, + 'subscribeall|subscribe_all!' => \$subscribeall, + 'justbanner!' => \$mysync->{ justbanner }, + 'justfolders!'=> \$mysync->{ justfolders }, + 'justfoldersizes!' => \$mysync->{ justfoldersizes }, + 'version' => \$mysync->{version}, + 'help' => \$help, + 'timeout=f' => \$mysync->{timeout}, + 'timeout1=f' => \$mysync->{ acc1 }->{timeout}, + 'timeout2=f' => \$mysync->{ acc2 }->{timeout}, + 'skipheader=s' => \$mysync->{ skipheader }, + 'useheader=s' => \@useheader, + 'wholeheaderifneeded!' => \$wholeheaderifneeded, + 'messageidnodomain!' => \$messageidnodomain, + 'skipsize!' => \$skipsize, + 'allowsizemismatch!' => \$allowsizemismatch, + 'fastio1!' => \$mysync->{ acc1 }->{ fastio }, + 'fastio2!' => \$mysync->{ acc2 }->{ fastio }, + 'sslcheck!' => \$mysync->{sslcheck}, + 'ssl1!' => \$mysync->{ssl1}, + 'ssl2!' => \$mysync->{ssl2}, + 'ssl1_ssl_version=s' => \$mysync->{ acc1 }->{sslargs}->{SSL_version}, + 'ssl2_ssl_version=s' => \$mysync->{ acc2 }->{sslargs}->{SSL_version}, + 'sslargs1=s%' => \$mysync->{ acc1 }->{sslargs}, + 'sslargs2=s%' => \$mysync->{ acc2 }->{sslargs}, + 'tls1!' => \$mysync->{tls1}, + 'tls2!' => \$mysync->{tls2}, + 'uid1!' => \$uid1, + 'uid2!' => \$uid2, + 'authmech1=s' => \$mysync->{ acc1 }->{ authmech }, + 'authmech2=s' => \$mysync->{ acc2 }->{ authmech }, + 'authuser1=s' => \$mysync->{ acc1 }->{ authuser }, + 'authuser2=s' => \$mysync->{ acc2 }->{ authuser }, + 'proxyauth1' => \$mysync->{ acc1 }->{ proxyauth }, + 'proxyauth2' => \$mysync->{ acc2 }->{ proxyauth }, + 'compress1!' => \$mysync->{ acc1 }->{ compress }, + 'compress2!' => \$mysync->{ acc2 }->{ compress }, + 'keepalive1!' => \$mysync->{ acc1 }->{ keepalive }, + 'keepalive2!' => \$mysync->{ acc2 }->{ keepalive }, + 'split1=i' => \$split1, + 'split2=i' => \$split2, + 'buffersize=i' => \$buffersize, + 'reconnectretry1=i' => \$mysync->{ acc1 }->{ reconnectretry }, + 'reconnectretry2=i' => \$mysync->{ acc2 }->{ reconnectretry }, + 'tests!' => \$mysync->{ tests }, + 'testsdebug|tests_debug!' => \$mysync->{ testsdebug }, + 'testsunit=s@' => \$mysync->{testsunit}, + 'testslive!' => \$mysync->{testslive}, + 'testslive6!' => \$mysync->{testslive6}, + 'justlogin!' => \$mysync->{justlogin}, + 'justconnect!' => \$mysync->{justconnect}, + 'tmpdir=s' => \$mysync->{ tmpdir }, + 'pidfile=s' => \$mysync->{pidfile}, + 'pidfilelocking!' => \$mysync->{pidfilelocking}, + 'sigexit=s@' => \$mysync->{ sigexit }, + 'sigreconnect=s@' => \$mysync->{ sigreconnect }, + 'sigignore=s@' => \$mysync->{ sigignore }, + 'releasecheck!' => \$mysync->{releasecheck}, + 'modulesversion|modules_version!' => \$modulesversion, + 'usecache!' => \$mysync->{ usecache }, + 'cacheaftercopy!' => \$cacheaftercopy, + 'debugcache!' => \$debugcache, + 'useuid!' => \$useuid, + 'addheader!' => \$mysync->{addheader}, + 'exitwhenover=i' => \$mysync->{ exitwhenover }, + 'exitonload!' => \$mysync->{ exitonload }, + 'checkselectable!' => \$mysync->{ checkselectable }, + 'checkfoldersexist!' => \$mysync->{ checkfoldersexist }, + 'checkmessageexists!' => \$checkmessageexists, + 'expungeaftereach!' => \$mysync->{ expungeaftereach }, + 'abletosearch!' => \$mysync->{abletosearch}, + 'abletosearch1!' => \$mysync->{abletosearch1}, + 'abletosearch2!' => \$mysync->{abletosearch2}, + 'showpasswords!' => \$mysync->{showpasswords}, + 'maxlinelength=i' => \$maxlinelength, + 'maxlinelengthcmd=s' => \$maxlinelengthcmd, + 'minmaxlinelength=i' => \$minmaxlinelength, + 'debugmaxlinelength!' => \$debugmaxlinelength, + 'fixcolonbug!' => \$fixcolonbug, + 'create_folder_old!' => \$create_folder_old, + 'maxmessagespersecond=f' => \$mysync->{maxmessagespersecond}, + 'maxbytespersecond=i' => \$mysync->{maxbytespersecond}, + 'maxbytesafter=i' => \$mysync->{maxbytesafter}, + 'maxsleep=f' => \$mysync->{maxsleep}, + 'syncduplicates!' => \$mysync->{ syncduplicates }, + 'skipcrossduplicates!' => \$mysync->{ skipcrossduplicates }, + 'debugcrossduplicates!' => \$mysync->{ debugcrossduplicates }, + 'log!' => \$mysync->{log}, + 'tail!' => \$mysync->{tail}, + 'logfile=s' => \$mysync->{logfile}, + 'logdir=s' => \$mysync->{logdir}, + 'errorsmax=i' => \$mysync->{errorsmax}, + 'errorsdump!' => \$mysync->{ errorsdump }, + 'fetch_hash_set=s' => \$fetch_hash_set, + 'automap!' => \$mysync->{automap}, + 'justautomap!' => \$mysync->{justautomap}, + 'id!' => \$mysync->{id}, + 'f1f2=s@' => \$mysync->{f1f2}, + 'nof1f2' => \$mysync->{nof1f2}, + 'f1f2h=s%' => \$mysync->{f1f2h}, + 'justfolderlists!' => \$mysync->{justfolderlists}, + 'delete1emptyfolders' => \$mysync->{delete1emptyfolders}, + 'checknoabletosearch!' => \$mysync->{checknoabletosearch}, + 'dockercontext!' => \$mysync->{ dockercontext }, + 'emailreportfrom=s' => \$mysync->{ email_report_from }, + 'emailreport1!' => \$mysync->{ emailreport1 }, + 'emailreport2!' => \$mysync->{ emailreport2 }, + 'var=s@' => \$mysync->{ var }, + 'memorystress!' => \$mysync->{ memorystress }, + ) ; + #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; + $mysync->{ debug } and output( $mysync, "get options: [$opt_ret][$numopt]\n" ) ; + my $numopt_after = scalar @arguments ; + #myprint( "get options: [$opt_ret][$numopt][$numopt_after]\n" ) ; + + # The $arguments[0] test is just because parallel adds "" when it is + # used with {=7=} in sync_parallel_unix.sh + if ( $numopt_after and $arguments[0] ) { + myprint( + "Found ", scalar( @arguments ), " extra arguments : [@arguments]\n", + "It usually means a quoting issue in the command line ", + "or some misspelling options.\n", + ) ; + return ; + } + if ( ! $opt_ret ) { + return ; + } + return $numopt ; +} + + + +sub tests_get_options +{ + note( 'Entering tests_get_options()' ) ; + + # CAVEAT: still setting global variables, be careful + # with tests, the context increases! $debug stays on for example. + # API: + # * input arguments: two ways, command line or CGI + # * the program arguments + # * QUERY_STRING env variable + # * return + # * undef if bad things happened like + # * options not known + # * --delete 2 input + # * number of arguments or QUERY_STRING length + my $mysync = { } ; + is( undef, get_options( $mysync, qw( --noexist ) ), 'get_options: --noexist => undef' ) ; + is( undef, $mysync->{ noexist }, 'get_options: --noexist => undef' ) ; + $mysync = { } ; + is( undef, get_options( $mysync, qw( --lalala --noexist --version ) ), 'get_options: --lalala --noexist --version => undef' ) ; + is( 1, $mysync->{ version }, 'get_options: --version => 1' ) ; + is( undef, $mysync->{ noexist }, 'get_options: --noexist => undef' ) ; + $mysync = { } ; + is( 1, get_options( $mysync, qw( --delete2 ) ), 'get_options: --delete2 => 1' ) ; + is( 1, $mysync->{ delete2 }, 'get_options: --delete2 => var delete2 = 1' ) ; + $mysync = { } ; + is( undef, get_options( $mysync, qw( --delete 2 ) ), 'get_options: --delete 2 => var undef' ) ; + is( undef, $mysync->{ delete1 }, 'get_options: --delete 2 => var still undef ; good!' ) ; + $mysync = { } ; + is( undef, get_options( $mysync, "--delete 2" ), 'get_options: --delete 2 => undef' ) ; + + is( 1, get_options( $mysync, "--version" ), 'get_options: --version => 1' ) ; + is( 1, get_options( $mysync, "--help" ), 'get_options: --help => 1' ) ; + + is( undef, get_options( $mysync, qw( --noexist --version ) ), 'get_options: --debug --noexist --version => undef' ) ; + is( 1, get_options( $mysync, qw( --version ) ), 'get_options: --version => 1' ) ; + is( undef, get_options( $mysync, qw( extra ) ), 'get_options: extra => undef' ) ; + is( undef, get_options( $mysync, qw( extra1 --version extra2 ) ), 'get_options: extra1 --version extra2 => undef' ) ; + + $mysync = { } ; + is( 2, get_options( $mysync, qw( --host1 HOST_01) ), 'get_options: --host1 HOST_01 => 1' ) ; + is( 'HOST_01', $mysync->{ host1 }, 'get_options: --host1 HOST_01 => HOST_01' ) ; + #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; + + note( 'Leaving tests_get_options()' ) ; + return ; +} + + + +sub get_options +{ + my $mysync = shift @ARG ; + my @arguments = @ARG ; + #myprint( "1 mysync: ", Data::Dumper->Dump( [ $mysync ] ) ) ; + my $ret ; + if ( under_cgi_context( ) ) { + # CGI context + $ret = get_options_cgi( $mysync, @arguments ) ; + }else{ + # Command line context ; + $ret = get_options_cmd( $mysync, @arguments ) ; + } ; + #myprint( "2 mysync: ", Data::Dumper->Dump( [ $mysync ] ) ) ; + + foreach my $key ( sort keys %{ $mysync } ) { + if ( ! defined $mysync->{$key} ) { + delete $mysync->{$key} ; + next ; + } + if ( 'ARRAY' eq ref( $mysync->{$key} ) + and 0 == scalar( @{ $mysync->{$key} } ) ) { + delete $mysync->{$key} ; + } + } + return $ret ; +} + + +sub tests_infos +{ + note( 'Entering tests_infos()' ) ; + note( "OSNAME=$OSNAME" ) ; + note( "hostname=". hostname( ) ) ; + note( "cwd=" . getcwd( ) ) ; + note( "PROGRAM_NAME=$PROGRAM_NAME" ) ; + my $stat = stat( "$PROGRAM_NAME" ) ; + my $perms = sprintf( "%04o\n", $stat->mode & oct( $PERMISSION_FILTER ) ) ; + note( "permissions=$perms" ) ; + note( "PROCESS_ID=$PROCESS_ID" ) ; + note( "REAL_USER_ID=$REAL_USER_ID" ) ; + note( "EFFECTIVE_USER_ID=$EFFECTIVE_USER_ID" ) ; + note( "context: " . imapsync_context( $sync ) ) ; + note( "memory_consumption_of_myself: " . memory_consumption_of_myself( ) . " bytes aka " . bytes_display_string_dec( memory_consumption_of_myself( ) ) ) ; + note( "cpu_number: " . cpu_number( ) ) ; + note( $sync->{ rcs } ) ; + note( 'Leaving tests_infos()' ) ; + return ; +} + + + +sub condition_to_leave_after_tests +{ + my $mysync = shift @ARG ; + if ( $mysync->{ testslive } or $mysync->{ testslive6 } ) + { + return 0 ; + } + + if ( $mysync->{ tests } + or $mysync->{ testsdebug } + or $mysync->{ testsunit } + ) + { + return 1 ; + } +} + + +sub testunitsession +{ + my $mysync = shift @ARG ; + + if ( ! $mysync ) { return ; } + if ( ! $mysync->{ testsunit } ) { return ; } + + my @functions = @{ $mysync->{ testsunit } } ; + + if ( ! @functions ) { return ; } + + SKIP: { + if ( ! @functions ) { skip 'No test in normal run' ; } + testsunit( @functions ) ; + done_testing( ) ; + } + return ; +} + +sub tests_count_0s +{ + note( 'Entering tests_count_zeros()' ) ; + is( 0, count_0s( ), 'count_0s: no parameters => 0' ) ; + is( 1, count_0s( 0 ), 'count_0s: 0 => 1' ) ; + is( 0, count_0s( 1 ), 'count_0s: 1 => 0' ) ; + is( 1, count_0s( 1, 0, 1 ), 'count_0s: 1, 0, 1 => 1' ) ; + is( 2, count_0s( 1, 0, 1, 0 ), 'count_0s: 1, 0, 1, 0 => 2' ) ; + note( 'Leaving tests_count_zeros()' ) ; + return ; +} +sub count_0s +{ + my @array = @ARG ; + + if ( ! @array ) { return 0 ; } + my $nb_zeros = 0 ; + map { $_ == 0 and $nb_zeros += 1 } @array ; + return $nb_zeros ; +} + +sub tests_report_failures +{ + note( 'Entering tests_report_failures()' ) ; + + is( undef, report_failures( ), 'report_failures: no parameters => undef' ) ; + is( "nb 1 - first\n", report_failures( ({'ok' => 0, name => 'first'}) ), 'report_failures: "first" failed => nb 1 - first' ) ; + is( q{}, report_failures( ( {'ok' => 1, name => 'first'} ) ), 'report_failures: "first" success =>' ) ; + is( "nb 2 - second\n", report_failures( ( {'ok' => 1, name => 'second'}, {'ok' => 0, name => 'second'} ) ), 'report_failures: "second" failed => nb 2 - second' ) ; + is( "nb 1 - first\nnb 2 - second\n", report_failures( ( {'ok' => 0, name => 'first'}, {'ok' => 0, name => 'second'} ) ), 'report_failures: both failed => nb 1 - first nb 2 - second' ) ; + note( 'Leaving tests_report_failures()' ) ; + return ; +} + +sub report_failures +{ + my @details = @ARG ; + + if ( ! @details ) { return ; } + + my $counter = 1 ; + my $report = q{} ; + foreach my $details ( @details ) { + if ( ! $details->{ 'ok' } ) { + my $name = $details->{ 'name' } || 'NONAME' ; + $report .= "nb $counter - $name\n" ; + } + $counter += 1 ; + } + return $report ; + +} + +sub tests_true +{ + note( 'Entering tests_true()' ) ; + + is( 1, 1, 'true: 1 is 1' ) ; + is( 'A', 'A', 'true: A is A' ) ; + note( 'Leaving tests_true()' ) ; + return ; +} + + +sub tests_always_fail +{ + note( 'Entering tests_always_fail()' ) ; + + is( 0, 1, 'always_fail: 0 is 1' ) ; + isnt( 'A', 'A', 'always_fail: A is A' ) ; + + note( 'Leaving tests_always_fail()' ) ; + return ; +} + + +sub tests_testsunit +{ + note( 'Entering tests_testunit()' ) ; + + is( undef, testsunit( ), 'testsunit: no parameters => undef' ) ; + is( undef, testsunit( undef ), 'testsunit: an undef parameter => undef' ) ; + is( undef, testsunit( q{} ), 'testsunit: an empty parameter => undef' ) ; + is( undef, testsunit( 'idonotexist' ), 'testsunit: a do not exist function as parameter => undef' ) ; + is( undef, testsunit( 'tests_true' ), 'testsunit: tests_true => undef' ) ; + note( 'Leaving tests_testunit()' ) ; + return ; +} + +sub testsunit +{ + my @functions = @ARG ; + + if ( ! @functions ) { # + myprint( "testsunit warning: no argument given\n" ) ; + return ; + } + + foreach my $function ( @functions ) { + if ( ! $function ) { + myprint( "testsunit warning: argument is empty\n" ) ; + next ; + } + if ( ! exists &$function ) { + myprint( "testsunit warning: function $function does not exist\n" ) ; + next ; + } + if ( ! defined &$function ) { + myprint( "testsunit warning: function $function is not defined\n" ) ; + next ; + } + my $function_ref = \&{ $function } ; + &$function_ref() ; + } + return ; +} + +sub testsdebug +{ + # Now a little obsolete since there is + # imapsync ... --testsunit "anyfunction" + my $mysync = shift @ARG ; + if ( ! $mysync->{ testsdebug } ) { return ; } + SKIP: { + if ( ! $mysync->{ testsdebug } ) { + skip 'No test in normal run' ; + } + + note( 'Entering testsdebug()' ) ; + #ok( ( ( not -d 'W/tmp/tests' ) or rmtree( 'W/tmp/tests/' ) ), 'testsdebug: rmtree W/tmp/tests' ) ; + #tests_check_binary_embed_all_dyn_libs( ) ; + #tests_killpid_by_parent( ) ; + #tests_killpid_by_brother( ) ; + #tests_kill_zero( ) ; + #tests_connect_socket( ) ; + #tests_probe_imapssl( ) ; + #tests_mailimapclient_connect( ) ; + #tests_always_fail( ) ; + #tests_localtimez( ) ; + #tests_year_month_day_hour_min_sec_ms( ) ; + #tests_date_rfc822( ) ; + #tests_email_report_message_id( ) ; + tests_all_pids( ) ; + tests_memory_consumption_of_myself( ) ; + tests_ram_memory_info( ) ; + tests_memory_consumption_of_all_pids( ) ; + tests_memory_consumption_all_pids_percent( ) ; + + #tests_memory_stress( ) ; + + tests_memory_consumption_of_pids_win32( ) ; + + #tests_load_and_delay( ) ; + #tests_cpu_number( ) ; + #tests_loadavg( ) ; + #tests_load_per_cpu( ) ; + #tests_all_pids( ) ; + #tests_remove_qq( ) ; + #tests_remove_not_num( ) ; + + tests_infos( ) ; + + note( 'Leaving testsdebug()' ) ; + done_testing( ) ; + } + return ; +} + + +sub tests +{ + my $mysync = shift @ARG ; + if ( ! $mysync->{ tests } ) { return ; } + + SKIP: { + skip 'No test in normal run' if ( ! $mysync->{ tests } ) ; + note( 'Entering tests()' ) ; + tests_folder_routines( ) ; + tests_compare_lists( ) ; + tests_regexmess( ) ; + tests_skipmess( ) ; + tests_regexflags( ); + tests_ucsecond( ) ; + tests_permanentflags(); + tests_flags_filter( ) ; + tests_separator_invert( ) ; + tests_imap2_folder_name( ) ; + tests_command_line_nopassword( ) ; + tests_good_date( ) ; + tests_max( ) ; + tests_remove_not_num(); + tests_memory_consumption_of_myself( ) ; + tests_is_a_release_number(); + tests_imapsync_basename(); + tests_list_keys_in_2_not_in_1(); + tests_convert_sep_to_slash( ) ; + tests_match_a_cache_file( ) ; + tests_cache_map( ) ; + tests_get_cache( ) ; + tests_clean_cache( ) ; + tests_clean_cache_2( ) ; + tests_touch( ) ; + tests_flagscase( ) ; + tests_mkpath( ) ; + tests_extract_header( ) ; + tests_decompose_header( ) ; + tests_epoch( ) ; + tests_add_header( ) ; + tests_cache_dir_fix( ) ; + tests_cache_dir_fix_win( ) ; + tests_filter_forbidden_characters( ) ; + tests_cache_folder( ) ; + tests_time_remaining( ) ; + tests_decompose_regex( ) ; + tests_backtick( ) ; + tests_bytes_display_string_bin( ) ; + tests_bytes_display_string_dec( ) ; + tests_header_line_normalize( ) ; + tests_fix_Inbox_INBOX_mapping( ) ; + tests_max_line_length( ) ; + tests_subject( ) ; + tests_msgs_from_maxmin( ) ; + tests_tmpdir_has_colon_bug( ) ; + tests_sleep_max_messages( ) ; + tests_sleep_max_bytes( ) ; + tests_logfile( ) ; + tests_setlogfile( ) ; + tests_jux_utf8_old( ) ; + tests_jux_utf8( ) ; + tests_pipemess( ) ; + tests_jux_utf8_list( ) ; + tests_guess_prefix( ) ; + tests_guess_separator( ) ; + tests_format_for_imap_arg( ) ; + tests_imapsync_id( ) ; + tests_date_from_rcs( ) ; + tests_quota_extract_storage_limit_in_bytes( ) ; + tests_quota_extract_storage_current_in_bytes( ) ; + tests_guess_special( ) ; + tests_do_valid_directory( ) ; + tests_delete1emptyfolders( ) ; + tests_message_for_host2( ) ; + tests_length_ref( ) ; + tests_firstline( ) ; + tests_diff_or_NA( ) ; + tests_match_number( ) ; + tests_all_defined( ) ; + tests_special_from_folders_hash( ) ; + tests_notmatch( ) ; + tests_match( ) ; + tests_get_options( ) ; + tests_get_options_cgi_context( ) ; + tests_rand32( ) ; + tests_hashsynclocal( ) ; + tests_hashsync( ) ; + tests_output( ) ; + tests_output_reset_with( ) ; + tests_output_start( ) ; + tests_check_last_release( ) ; + tests_loadavg( ) ; + tests_cpu_number( ) ; + tests_load_and_delay( ) ; + #tests_imapsping( ) ; + #tests_tcpping( ) ; + tests_sslcheck( ) ; + tests_not_long_imapsync_version_public( ) ; + tests_reconnect_if_needed( ) ; + tests_reconnect_12_if_needed( ) ; + tests_sleep_if_needed( ) ; + tests_string_to_file( ) ; + tests_file_to_string( ) ; + tests_under_cgi_context( ) ; + tests_umask( ) ; + tests_umask_str( ) ; + tests_set_umask( ) ; + tests_createhashfileifneeded( ) ; + tests_slash_to_underscore( ) ; + tests_testsunit( ) ; + tests_count_0s( ) ; + tests_report_failures( ) ; + tests_min( ) ; + #tests_connect_socket( ) ; + #tests_resolvrev( ) ; + tests_usage( ) ; + tests_version_from_rcs( ) ; + tests_backslash_caret( ) ; + #tests_mailimapclient_connect_bug( ) ; # it fails with Mail-IMAPClient <= 3.39 + tests_write_pidfile( ) ; + tests_remove_pidfile_not_running( ) ; + tests_match_a_pid_number( ) ; + tests_prefix_seperator_invertion( ) ; + tests_is_integer( ) ; + tests_integer_or_1( ) ; + tests_is_number( ) ; + tests_sig_install( ) ; + tests_template( ) ; + tests_split_around_equal( ) ; + tests_toggle_sleep( ) ; + tests_labels( ) ; + tests_synclabels( ) ; + tests_uidexpunge_or_expunge( ) ; + tests_appendlimit_from_capability( ) ; + tests_maxsize_setting( ) ; + tests_mock_capability( ) ; + tests_appendlimit( ) ; + tests_capability_of( ) ; + tests_search_in_array( ) ; + tests_operators_and_exclam_precedence( ) ; + tests_teelaunch( ) ; + tests_logfileprepa( ) ; + tests_useheader_suggestion( ) ; + tests_nb_messages_in_2_not_in_1( ) ; + tests_labels_add_subfolder2( ) ; + tests_labels_remove_subfolder1( ) ; + tests_resynclabels( ) ; + tests_labels_remove_special( ) ; + tests_uniq( ) ; + tests_remove_from_requested_folders( ) ; + tests_errors_log( ) ; + tests_add_subfolder1_to_folderrec( ) ; + tests_sanitize_subfolder( ) ; + tests_remove_edging_blanks( ) ; + tests_sanitize( ) ; + tests_remove_last_char_if_is( ) ; + tests_check_binary_embed_all_dyn_libs( ) ; + tests_nthline( ) ; + tests_secondline( ) ; + tests_tail( ) ; + tests_truncmess( ) ; + tests_eta( ) ; + tests_timesince( ) ; + tests_timenext( ) ; + tests_imapsync_context( ) ; + tests_abort( ) ; + tests_probe_imapssl( ) ; + tests_mailimapclient_connect( ) ; + tests_checknoabletosearch( ) ; + tests_errorsdump( ) ; + tests_errorsanalyse( ) ; + tests_most_common_error( ) ; + tests_errorclassify( ) ; + tests_error_type( ) ; + tests_sanitize_host( ) ; + tests_hmac_sha1_hex( ) ; + tests_total_bytes_max_reached( ) ; + tests_header_construct( ) ; + tests_remove_doublequotes_if_any( ) ; + tests_login_imap( ) ; + tests_login_imap_oauth( ) ; + tests_skipmess_neg( ) ; + tests_localtimez( ) ; + tests_file_to_array( ) ; + tests_cpu_time( ) ; + tests_cpu_percent( ) ; + tests_cpu_percent_global( ) ; + tests_flags_for_host2( ) ; + tests_under_docker_context( ) ; + tests_exit_value( ) ; + tests_comment_of_error_type( ) ; + tests_debugcontent( ) ; + tests_compress_ssl( ) ; + tests_compress( ) ; + tests_get_options_extra( ) ; + tests_get_options_from_string( ) ; + tests_email_report_message_id( ) ; + tests_year_month_day_hour_min_sec_ms( ) ; + tests_fractional_of_floor( ) ; + tests_date_rfc822( ) ; + tests_email_report_from( ) ; + tests_email_report_to( ) ; + tests_email_report_body_base( ) ; + tests_email_report( ) ; + tests_setlogdir( ) ; + tests_logfilesuffix( ) ; + tests_cgienvcontext( ) ; + tests_usecache_and_skipcrossduplicates( ) ; + tests_loglogfile( ) ; + tests_heavy_load_reached( ) ; + tests_heavy_load_percent_threshold( ) ; + tests_pctmem_available( ) ; + tests_filterbuggyflags( ) ; + tests_heavy_load_reached_by_memory( ) ; + tests_heavy_load_reached_by_cpu( ) ; + tests_load_per_cpu( ) ; + tests_memory_consumption_surface( ) ; + tests_add( ) ; + tests_all_pids( ) ; + tests_memory_consumption_of_all_pids( ) ; + tests_remove_qq( ) ; + tests_memory_consumption_all_pids_percent( ) ; + tests_ram_memory_info( ) ; + + tests_infos( ) ; + #tests_resolv( ) ; + + # Those three are for later use, when webserver will be inside imapsync + # or will be deleted them if I abandon the project. + #tests_killpid_by_parent( ) ; + #tests_killpid_by_brother( ) ; + #tests_kill_zero( ) ; + + #tests_always_fail( ) ; + + done_testing( 1992 ) ; + note( 'Leaving tests()' ) ; + } + return ; +} + +sub tests_template +{ + note( 'Entering tests_template()' ) ; + + is( undef, template( ), 'tests_template: no args => undef' ) ; + my $mysync = { } ; + is( undef, template( $mysync ), 'tests_template: { } => undef' ) ; + is_deeply( {}, {}, 'tests_template: a hash is a hash' ) ; + is_deeply( [], [], 'tests_template: an array is an array' ) ; + + note( 'Leaving tests_template()' ) ; + return ; +} + +sub template +{ + my $mysync = shift @ARG ; + + return ; +} +