diff options
Diffstat (limited to 'third_party')
361 files changed, 45840 insertions, 0 deletions
diff --git a/third_party/README.md b/third_party/README.md new file mode 100644 index 0000000000..267f234697 --- /dev/null +++ b/third_party/README.md @@ -0,0 +1,13 @@ +Third-Party Code +================ + +Code under this folder is one of the following: + +1. Externally developed dependencies which have been imported ("vendored") into + this repository. These dependencies come with their own licenses and whatever + else. + +2. Code that is developed inside of this repository, but released to an external + repository via [Copybara][]. + +[Copybara]: https://github.com/google/copybara diff --git a/third_party/agenix/default.nix b/third_party/agenix/default.nix new file mode 100644 index 0000000000..1462050ef1 --- /dev/null +++ b/third_party/agenix/default.nix @@ -0,0 +1,15 @@ +{ pkgs, depot, ... }: + +let + src = depot.third_party.sources.agenix; + + agenix = import src { + inherit pkgs; + }; +in +{ + inherit src; + cli = agenix.agenix; + + meta.ci.targets = [ "cli" ]; +} diff --git a/third_party/alsi/OWNERS b/third_party/alsi/OWNERS new file mode 100644 index 0000000000..b381c4e660 --- /dev/null +++ b/third_party/alsi/OWNERS @@ -0,0 +1 @@ +aspen diff --git a/third_party/alsi/default.nix b/third_party/alsi/default.nix new file mode 100644 index 0000000000..8969374176 --- /dev/null +++ b/third_party/alsi/default.nix @@ -0,0 +1,25 @@ +{ pkgs, ... }: + +with pkgs; + +stdenv.mkDerivation { + name = "alsi"; + pname = "alsi"; + version = "0.4.8"; + + src = fetchFromGitHub { + owner = "trizen"; + repo = "alsi"; + rev = "fe2a925caad38d4cc7afe10d74ba60c5db09ee66"; + sha256 = "060xlalfclrda5f1h3svj4v2gr19mdrsc62vrg7hgii0f3lib7j5"; + }; + + buildInputs = [ + (perl.withPackages (ps: with ps; [ DataDump ])) + ]; + + installPhase = '' + mkdir -p $out/bin + cp alsi $out/bin/alsi + ''; +} diff --git a/third_party/bat_syntaxes/Prolog.sublime-syntax b/third_party/bat_syntaxes/Prolog.sublime-syntax new file mode 100644 index 0000000000..b03066ac06 --- /dev/null +++ b/third_party/bat_syntaxes/Prolog.sublime-syntax @@ -0,0 +1,1319 @@ +# SPDX-License-Identifier: MIT +# Generated from code at https://github.com/BenjaminSchaaf/swi-prolog-sublime-syntax +--- +# http://www.sublimetext.com/docs/3/syntax.html +name: Prolog +file_extensions: + - pl + - pro +first_line_match: '^#!.*\bswipl\b' +scope: source.prolog +contexts: + atom-entity|meta: + - meta_content_scope: entity.name.predicate.prolog + - match: '' + pop: true + atom-functor|meta: + - meta_content_scope: meta.path.prolog variable.function.functor.prolog + - match: '' + pop: true + atom-string|0: + - meta_include_prototype: false + - match: '\\([abcefnrstv''\"`\n\\]|x\h\h+\\?|u\h{4}|U\h{8})' + scope: constant.character.escape.prolog + - match: '''' + pop: true + compound-term|0: + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: meta.path.prolog variable.function.functor.prolog + set: [compound-term|1, value-without-comma|0, single-value|0] + - match: '''' + scope: meta.path.prolog variable.function.functor.prolog + set: [compound-term|1, value-without-comma|0, single-value|0, atom-functor|meta, atom-string|0] + - match: '([~^&*\-+=|\\/<>][~^&*\-+=|\\/<>.,]*)(\()' + captures: + 1: constant.character.swi-prolog.prolog + 2: punctuation.section.parens.begin.prolog + set: [compound-term|1, value-without-comma|0, operator-compound-term|0] + - match: '!' + scope: keyword.control.cut.prolog + set: [compound-term|1, value-without-comma|0] + - match: '(0b)[01_]+' + scope: constant.numeric.integer.binary.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [compound-term|1, value-without-comma|0] + - match: '(0x)[\h_]+' + scope: constant.numeric.integer.hexadecimal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [compound-term|1, value-without-comma|0] + - match: '(0o)[0-7_]+' + scope: constant.numeric.integer.octal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [compound-term|1, value-without-comma|0] + - match: '([0-9]{1,2})('')[0-9a-z]+' + scope: constant.numeric.integer.prolog + captures: + 1: punctuation.definition.number.base.prolog + 2: punctuation.separator.base.prolog + set: [compound-term|1, value-without-comma|0] + - match: '[0-9]+\.[0-9]+' + scope: constant.numeric.float.prolog + set: [compound-term|1, value-without-comma|0] + - match: '[+-]?[0-9_]+' + scope: constant.numeric.integer.prolog + set: [compound-term|1, value-without-comma|0, number|0] + - match: '\b[A-Z][[:alpha:]0-9_]*\b|\b_[[:alpha:]0-9_]+\b' + scope: variable.parameter.prolog + set: [compound-term|1, value-without-comma|0] + - match: '_' + scope: language.constant.underscore.prolog + set: [compound-term|1, value-without-comma|0] + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.begin.prolog + set: [compound-term|1, value-without-comma|0, string|0] + - match: '\[' + scope: punctuation.section.brackets.begin.prolog + set: [compound-term|1, value-without-comma|0, list|0] + - match: '\{' + scope: punctuation.section.braces.begin.prolog + set: [compound-term|1, value-without-comma|0, set|0] + - match: '\+|-' + scope: keyword.operator.arithmetic.prolog + set: [compound-term|1, value-without-comma|0, single-value|1] + - match: '\\\+' + scope: keyword.control.negation.prolog + set: [compound-term|1, value-without-comma|0, single-value|1] + - match: '\(' + scope: punctuation.section.group.begin.prolog + set: [compound-term|1, value-without-comma|0, single-value|2] + - match: '\)' + scope: punctuation.section.parens.end.prolog + pop: true + - match: '\S' + scope: invalid.illegal.prolog + pop: true + compound-term|1: + - match: ',' + scope: punctuation.separator.sequence.prolog + push: compound-term|2 + - match: '\)' + scope: punctuation.section.parens.end.prolog + pop: true + - match: '\S' + scope: invalid.illegal.prolog + pop: true + compound-term|2: + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: meta.path.prolog variable.function.functor.prolog + set: [value-without-comma|0, single-value|0] + - match: '''' + scope: meta.path.prolog variable.function.functor.prolog + set: [value-without-comma|0, single-value|0, atom-functor|meta, atom-string|0] + - match: '([~^&*\-+=|\\/<>][~^&*\-+=|\\/<>.,]*)(\()' + captures: + 1: constant.character.swi-prolog.prolog + 2: punctuation.section.parens.begin.prolog + set: [value-without-comma|0, operator-compound-term|0] + - match: '!' + scope: keyword.control.cut.prolog + set: value-without-comma|0 + - match: '(0b)[01_]+' + scope: constant.numeric.integer.binary.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: value-without-comma|0 + - match: '(0x)[\h_]+' + scope: constant.numeric.integer.hexadecimal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: value-without-comma|0 + - match: '(0o)[0-7_]+' + scope: constant.numeric.integer.octal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: value-without-comma|0 + - match: '([0-9]{1,2})('')[0-9a-z]+' + scope: constant.numeric.integer.prolog + captures: + 1: punctuation.definition.number.base.prolog + 2: punctuation.separator.base.prolog + set: value-without-comma|0 + - match: '[0-9]+\.[0-9]+' + scope: constant.numeric.float.prolog + set: value-without-comma|0 + - match: '[+-]?[0-9_]+' + scope: constant.numeric.integer.prolog + set: [value-without-comma|0, number|0] + - match: '\b[A-Z][[:alpha:]0-9_]*\b|\b_[[:alpha:]0-9_]+\b' + scope: variable.parameter.prolog + set: value-without-comma|0 + - match: '_' + scope: language.constant.underscore.prolog + set: value-without-comma|0 + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.begin.prolog + set: [value-without-comma|0, string|0] + - match: '\[' + scope: punctuation.section.brackets.begin.prolog + set: [value-without-comma|0, list|0] + - match: '\{' + scope: punctuation.section.braces.begin.prolog + set: [value-without-comma|0, set|0] + - match: '\+|-' + scope: keyword.operator.arithmetic.prolog + set: [value-without-comma|0, single-value|1] + - match: '\\\+' + scope: keyword.control.negation.prolog + set: [value-without-comma|0, single-value|1] + - match: '\(' + scope: punctuation.section.group.begin.prolog + set: [value-without-comma|0, single-value|2] + - match: '\S' + scope: invalid.illegal.prolog + pop: true + fact|0: + - match: ':-' + scope: keyword.operator.definition.begin.prolog + set: fact|1 + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: meta.path.prolog variable.function.functor.prolog + set: [fact|2, value|0, single-value|0] + - match: '''' + scope: meta.path.prolog variable.function.functor.prolog + set: [fact|2, value|0, single-value|0, atom-functor|meta, atom-string|0] + - match: '([~^&*\-+=|\\/<>][~^&*\-+=|\\/<>.,]*)(\()' + captures: + 1: constant.character.swi-prolog.prolog + 2: punctuation.section.parens.begin.prolog + set: [fact|2, value|0, operator-compound-term|0] + - match: '!' + scope: keyword.control.cut.prolog + set: [fact|2, value|0] + - match: '(0b)[01_]+' + scope: constant.numeric.integer.binary.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [fact|2, value|0] + - match: '(0x)[\h_]+' + scope: constant.numeric.integer.hexadecimal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [fact|2, value|0] + - match: '(0o)[0-7_]+' + scope: constant.numeric.integer.octal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [fact|2, value|0] + - match: '([0-9]{1,2})('')[0-9a-z]+' + scope: constant.numeric.integer.prolog + captures: + 1: punctuation.definition.number.base.prolog + 2: punctuation.separator.base.prolog + set: [fact|2, value|0] + - match: '[0-9]+\.[0-9]+' + scope: constant.numeric.float.prolog + set: [fact|2, value|0] + - match: '[+-]?[0-9_]+' + scope: constant.numeric.integer.prolog + set: [fact|2, value|0, number|0] + - match: '\b[A-Z][[:alpha:]0-9_]*\b|\b_[[:alpha:]0-9_]+\b' + scope: variable.parameter.prolog + set: [fact|2, value|0] + - match: '_' + scope: language.constant.underscore.prolog + set: [fact|2, value|0] + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.begin.prolog + set: [fact|2, value|0, string|0] + - match: '\[' + scope: punctuation.section.brackets.begin.prolog + set: [fact|2, value|0, list|0] + - match: '\{' + scope: punctuation.section.braces.begin.prolog + set: [fact|2, value|0, set|0] + - match: '\+|-' + scope: keyword.operator.arithmetic.prolog + set: [fact|2, value|0, single-value|1] + - match: '\\\+' + scope: keyword.control.negation.prolog + set: [fact|2, value|0, single-value|1] + - match: '\(' + scope: punctuation.section.group.begin.prolog + set: [fact|2, value|0, single-value|2] + - match: '\S' + scope: invalid.illegal.prolog + pop: true + fact|1: + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: meta.path.prolog variable.function.functor.prolog + set: [fact|2, value|0, single-value|0] + - match: '''' + scope: meta.path.prolog variable.function.functor.prolog + set: [fact|2, value|0, single-value|0, atom-functor|meta, atom-string|0] + - match: '([~^&*\-+=|\\/<>][~^&*\-+=|\\/<>.,]*)(\()' + captures: + 1: constant.character.swi-prolog.prolog + 2: punctuation.section.parens.begin.prolog + set: [fact|2, value|0, operator-compound-term|0] + - match: '!' + scope: keyword.control.cut.prolog + set: [fact|2, value|0] + - match: '(0b)[01_]+' + scope: constant.numeric.integer.binary.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [fact|2, value|0] + - match: '(0x)[\h_]+' + scope: constant.numeric.integer.hexadecimal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [fact|2, value|0] + - match: '(0o)[0-7_]+' + scope: constant.numeric.integer.octal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [fact|2, value|0] + - match: '([0-9]{1,2})('')[0-9a-z]+' + scope: constant.numeric.integer.prolog + captures: + 1: punctuation.definition.number.base.prolog + 2: punctuation.separator.base.prolog + set: [fact|2, value|0] + - match: '[0-9]+\.[0-9]+' + scope: constant.numeric.float.prolog + set: [fact|2, value|0] + - match: '[+-]?[0-9_]+' + scope: constant.numeric.integer.prolog + set: [fact|2, value|0, number|0] + - match: '\b[A-Z][[:alpha:]0-9_]*\b|\b_[[:alpha:]0-9_]+\b' + scope: variable.parameter.prolog + set: [fact|2, value|0] + - match: '_' + scope: language.constant.underscore.prolog + set: [fact|2, value|0] + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.begin.prolog + set: [fact|2, value|0, string|0] + - match: '\[' + scope: punctuation.section.brackets.begin.prolog + set: [fact|2, value|0, list|0] + - match: '\{' + scope: punctuation.section.braces.begin.prolog + set: [fact|2, value|0, set|0] + - match: '\+|-' + scope: keyword.operator.arithmetic.prolog + set: [fact|2, value|0, single-value|1] + - match: '\\\+' + scope: keyword.control.negation.prolog + set: [fact|2, value|0, single-value|1] + - match: '\(' + scope: punctuation.section.group.begin.prolog + set: [fact|2, value|0, single-value|2] + - match: '\S' + scope: invalid.illegal.prolog + pop: true + fact|2: + - match: '\.' + scope: keyword.operator.definition.end.prolog + pop: true + - match: '\S' + scope: invalid.illegal.prolog + pop: true + list|0: + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: meta.path.prolog variable.function.functor.prolog + set: [list|1, value-without-comma|0, single-value|0] + - match: '''' + scope: meta.path.prolog variable.function.functor.prolog + set: [list|1, value-without-comma|0, single-value|0, atom-functor|meta, atom-string|0] + - match: '([~^&*\-+=|\\/<>][~^&*\-+=|\\/<>.,]*)(\()' + captures: + 1: constant.character.swi-prolog.prolog + 2: punctuation.section.parens.begin.prolog + set: [list|1, value-without-comma|0, operator-compound-term|0] + - match: '!' + scope: keyword.control.cut.prolog + set: [list|1, value-without-comma|0] + - match: '(0b)[01_]+' + scope: constant.numeric.integer.binary.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [list|1, value-without-comma|0] + - match: '(0x)[\h_]+' + scope: constant.numeric.integer.hexadecimal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [list|1, value-without-comma|0] + - match: '(0o)[0-7_]+' + scope: constant.numeric.integer.octal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [list|1, value-without-comma|0] + - match: '([0-9]{1,2})('')[0-9a-z]+' + scope: constant.numeric.integer.prolog + captures: + 1: punctuation.definition.number.base.prolog + 2: punctuation.separator.base.prolog + set: [list|1, value-without-comma|0] + - match: '[0-9]+\.[0-9]+' + scope: constant.numeric.float.prolog + set: [list|1, value-without-comma|0] + - match: '[+-]?[0-9_]+' + scope: constant.numeric.integer.prolog + set: [list|1, value-without-comma|0, number|0] + - match: '\b[A-Z][[:alpha:]0-9_]*\b|\b_[[:alpha:]0-9_]+\b' + scope: variable.parameter.prolog + set: [list|1, value-without-comma|0] + - match: '_' + scope: language.constant.underscore.prolog + set: [list|1, value-without-comma|0] + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.begin.prolog + set: [list|1, value-without-comma|0, string|0] + - match: '\[' + scope: punctuation.section.brackets.begin.prolog + set: [list|1, value-without-comma|0, list|0] + - match: '\{' + scope: punctuation.section.braces.begin.prolog + set: [list|1, value-without-comma|0, set|0] + - match: '\+|-' + scope: keyword.operator.arithmetic.prolog + set: [list|1, value-without-comma|0, single-value|1] + - match: '\\\+' + scope: keyword.control.negation.prolog + set: [list|1, value-without-comma|0, single-value|1] + - match: '\(' + scope: punctuation.section.group.begin.prolog + set: [list|1, value-without-comma|0, single-value|2] + - match: '\]' + scope: punctuation.section.brackets.end.prolog + pop: true + - match: '\S' + scope: invalid.illegal.prolog + pop: true + list|1: + - match: ',' + scope: punctuation.separator.sequence.prolog + push: list|2 + - match: '\|' + scope: punctuation.separator.sequence.prolog + set: list|3 + - match: '\]' + scope: punctuation.section.brackets.end.prolog + pop: true + - match: '\S' + scope: invalid.illegal.prolog + pop: true + list|2: + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: meta.path.prolog variable.function.functor.prolog + set: [value-without-comma|0, single-value|0] + - match: '''' + scope: meta.path.prolog variable.function.functor.prolog + set: [value-without-comma|0, single-value|0, atom-functor|meta, atom-string|0] + - match: '([~^&*\-+=|\\/<>][~^&*\-+=|\\/<>.,]*)(\()' + captures: + 1: constant.character.swi-prolog.prolog + 2: punctuation.section.parens.begin.prolog + set: [value-without-comma|0, operator-compound-term|0] + - match: '!' + scope: keyword.control.cut.prolog + set: value-without-comma|0 + - match: '(0b)[01_]+' + scope: constant.numeric.integer.binary.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: value-without-comma|0 + - match: '(0x)[\h_]+' + scope: constant.numeric.integer.hexadecimal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: value-without-comma|0 + - match: '(0o)[0-7_]+' + scope: constant.numeric.integer.octal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: value-without-comma|0 + - match: '([0-9]{1,2})('')[0-9a-z]+' + scope: constant.numeric.integer.prolog + captures: + 1: punctuation.definition.number.base.prolog + 2: punctuation.separator.base.prolog + set: value-without-comma|0 + - match: '[0-9]+\.[0-9]+' + scope: constant.numeric.float.prolog + set: value-without-comma|0 + - match: '[+-]?[0-9_]+' + scope: constant.numeric.integer.prolog + set: [value-without-comma|0, number|0] + - match: '\b[A-Z][[:alpha:]0-9_]*\b|\b_[[:alpha:]0-9_]+\b' + scope: variable.parameter.prolog + set: value-without-comma|0 + - match: '_' + scope: language.constant.underscore.prolog + set: value-without-comma|0 + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.begin.prolog + set: [value-without-comma|0, string|0] + - match: '\[' + scope: punctuation.section.brackets.begin.prolog + set: [value-without-comma|0, list|0] + - match: '\{' + scope: punctuation.section.braces.begin.prolog + set: [value-without-comma|0, set|0] + - match: '\+|-' + scope: keyword.operator.arithmetic.prolog + set: [value-without-comma|0, single-value|1] + - match: '\\\+' + scope: keyword.control.negation.prolog + set: [value-without-comma|0, single-value|1] + - match: '\(' + scope: punctuation.section.group.begin.prolog + set: [value-without-comma|0, single-value|2] + - match: '\S' + scope: invalid.illegal.prolog + pop: true + list|3: + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: meta.path.prolog variable.function.functor.prolog + set: [list|4, value-without-comma|0, single-value|0] + - match: '''' + scope: meta.path.prolog variable.function.functor.prolog + set: [list|4, value-without-comma|0, single-value|0, atom-functor|meta, atom-string|0] + - match: '([~^&*\-+=|\\/<>][~^&*\-+=|\\/<>.,]*)(\()' + captures: + 1: constant.character.swi-prolog.prolog + 2: punctuation.section.parens.begin.prolog + set: [list|4, value-without-comma|0, operator-compound-term|0] + - match: '!' + scope: keyword.control.cut.prolog + set: [list|4, value-without-comma|0] + - match: '(0b)[01_]+' + scope: constant.numeric.integer.binary.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [list|4, value-without-comma|0] + - match: '(0x)[\h_]+' + scope: constant.numeric.integer.hexadecimal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [list|4, value-without-comma|0] + - match: '(0o)[0-7_]+' + scope: constant.numeric.integer.octal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [list|4, value-without-comma|0] + - match: '([0-9]{1,2})('')[0-9a-z]+' + scope: constant.numeric.integer.prolog + captures: + 1: punctuation.definition.number.base.prolog + 2: punctuation.separator.base.prolog + set: [list|4, value-without-comma|0] + - match: '[0-9]+\.[0-9]+' + scope: constant.numeric.float.prolog + set: [list|4, value-without-comma|0] + - match: '[+-]?[0-9_]+' + scope: constant.numeric.integer.prolog + set: [list|4, value-without-comma|0, number|0] + - match: '\b[A-Z][[:alpha:]0-9_]*\b|\b_[[:alpha:]0-9_]+\b' + scope: variable.parameter.prolog + set: [list|4, value-without-comma|0] + - match: '_' + scope: language.constant.underscore.prolog + set: [list|4, value-without-comma|0] + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.begin.prolog + set: [list|4, value-without-comma|0, string|0] + - match: '\[' + scope: punctuation.section.brackets.begin.prolog + set: [list|4, value-without-comma|0, list|0] + - match: '\{' + scope: punctuation.section.braces.begin.prolog + set: [list|4, value-without-comma|0, set|0] + - match: '\+|-' + scope: keyword.operator.arithmetic.prolog + set: [list|4, value-without-comma|0, single-value|1] + - match: '\\\+' + scope: keyword.control.negation.prolog + set: [list|4, value-without-comma|0, single-value|1] + - match: '\(' + scope: punctuation.section.group.begin.prolog + set: [list|4, value-without-comma|0, single-value|2] + - match: '\S' + scope: invalid.illegal.prolog + pop: true + list|4: + - match: '\]' + scope: punctuation.section.brackets.end.prolog + pop: true + - match: '\S' + scope: invalid.illegal.prolog + pop: true + main: + - match: '^#!' + scope: comment.line.number-sign.prolog punctuation.definition.comment.number-sign.prolog + push: shebang|0 + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: entity.name.predicate.prolog + push: rule|0 + - match: '''' + scope: entity.name.predicate.prolog + push: [rule|0, atom-entity|meta, atom-string|0] + - match: '(?=\S)' + push: fact|0 + - match: '\S' + scope: invalid.illegal.prolog + nested-comment|0: + - meta_content_scope: comment.block.nested.prolog + - match: '/\*(\*(?!/))?' + scope: comment.block.nested.prolog punctuation.definition.comment.prolog + push: nested-comment|0 + - match: '\*/' + scope: comment.block.nested.prolog punctuation.definition.comment.prolog + pop: true + number|0: + - match: '[0-9_]+' + scope: constant.numeric.integer.prolog + - match: '(?=\S)' + pop: true + operator-compound-term|0: + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: meta.path.prolog variable.function.functor.prolog + set: [operator-compound-term|1, value-without-comma|0, single-value|0] + - match: '''' + scope: meta.path.prolog variable.function.functor.prolog + set: [operator-compound-term|1, value-without-comma|0, single-value|0, atom-functor|meta, atom-string|0] + - match: '([~^&*\-+=|\\/<>][~^&*\-+=|\\/<>.,]*)(\()' + captures: + 1: constant.character.swi-prolog.prolog + 2: punctuation.section.parens.begin.prolog + set: [operator-compound-term|1, value-without-comma|0, operator-compound-term|0] + - match: '!' + scope: keyword.control.cut.prolog + set: [operator-compound-term|1, value-without-comma|0] + - match: '(0b)[01_]+' + scope: constant.numeric.integer.binary.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [operator-compound-term|1, value-without-comma|0] + - match: '(0x)[\h_]+' + scope: constant.numeric.integer.hexadecimal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [operator-compound-term|1, value-without-comma|0] + - match: '(0o)[0-7_]+' + scope: constant.numeric.integer.octal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [operator-compound-term|1, value-without-comma|0] + - match: '([0-9]{1,2})('')[0-9a-z]+' + scope: constant.numeric.integer.prolog + captures: + 1: punctuation.definition.number.base.prolog + 2: punctuation.separator.base.prolog + set: [operator-compound-term|1, value-without-comma|0] + - match: '[0-9]+\.[0-9]+' + scope: constant.numeric.float.prolog + set: [operator-compound-term|1, value-without-comma|0] + - match: '[+-]?[0-9_]+' + scope: constant.numeric.integer.prolog + set: [operator-compound-term|1, value-without-comma|0, number|0] + - match: '\b[A-Z][[:alpha:]0-9_]*\b|\b_[[:alpha:]0-9_]+\b' + scope: variable.parameter.prolog + set: [operator-compound-term|1, value-without-comma|0] + - match: '_' + scope: language.constant.underscore.prolog + set: [operator-compound-term|1, value-without-comma|0] + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.begin.prolog + set: [operator-compound-term|1, value-without-comma|0, string|0] + - match: '\[' + scope: punctuation.section.brackets.begin.prolog + set: [operator-compound-term|1, value-without-comma|0, list|0] + - match: '\{' + scope: punctuation.section.braces.begin.prolog + set: [operator-compound-term|1, value-without-comma|0, set|0] + - match: '\+|-' + scope: keyword.operator.arithmetic.prolog + set: [operator-compound-term|1, value-without-comma|0, single-value|1] + - match: '\\\+' + scope: keyword.control.negation.prolog + set: [operator-compound-term|1, value-without-comma|0, single-value|1] + - match: '\(' + scope: punctuation.section.group.begin.prolog + set: [operator-compound-term|1, value-without-comma|0, single-value|2] + - match: '\)' + scope: punctuation.section.parans.end.prolog + pop: true + - match: '\S' + scope: invalid.illegal.prolog + pop: true + operator-compound-term|1: + - match: ',' + scope: punctuation.separator.sequence.prolog + push: operator-compound-term|2 + - match: '\)' + scope: punctuation.section.parans.end.prolog + pop: true + - match: '\S' + scope: invalid.illegal.prolog + pop: true + operator-compound-term|2: + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: meta.path.prolog variable.function.functor.prolog + set: [value-without-comma|0, single-value|0] + - match: '''' + scope: meta.path.prolog variable.function.functor.prolog + set: [value-without-comma|0, single-value|0, atom-functor|meta, atom-string|0] + - match: '([~^&*\-+=|\\/<>][~^&*\-+=|\\/<>.,]*)(\()' + captures: + 1: constant.character.swi-prolog.prolog + 2: punctuation.section.parens.begin.prolog + set: [value-without-comma|0, operator-compound-term|0] + - match: '!' + scope: keyword.control.cut.prolog + set: value-without-comma|0 + - match: '(0b)[01_]+' + scope: constant.numeric.integer.binary.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: value-without-comma|0 + - match: '(0x)[\h_]+' + scope: constant.numeric.integer.hexadecimal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: value-without-comma|0 + - match: '(0o)[0-7_]+' + scope: constant.numeric.integer.octal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: value-without-comma|0 + - match: '([0-9]{1,2})('')[0-9a-z]+' + scope: constant.numeric.integer.prolog + captures: + 1: punctuation.definition.number.base.prolog + 2: punctuation.separator.base.prolog + set: value-without-comma|0 + - match: '[0-9]+\.[0-9]+' + scope: constant.numeric.float.prolog + set: value-without-comma|0 + - match: '[+-]?[0-9_]+' + scope: constant.numeric.integer.prolog + set: [value-without-comma|0, number|0] + - match: '\b[A-Z][[:alpha:]0-9_]*\b|\b_[[:alpha:]0-9_]+\b' + scope: variable.parameter.prolog + set: value-without-comma|0 + - match: '_' + scope: language.constant.underscore.prolog + set: value-without-comma|0 + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.begin.prolog + set: [value-without-comma|0, string|0] + - match: '\[' + scope: punctuation.section.brackets.begin.prolog + set: [value-without-comma|0, list|0] + - match: '\{' + scope: punctuation.section.braces.begin.prolog + set: [value-without-comma|0, set|0] + - match: '\+|-' + scope: keyword.operator.arithmetic.prolog + set: [value-without-comma|0, single-value|1] + - match: '\\\+' + scope: keyword.control.negation.prolog + set: [value-without-comma|0, single-value|1] + - match: '\(' + scope: punctuation.section.group.begin.prolog + set: [value-without-comma|0, single-value|2] + - match: '\S' + scope: invalid.illegal.prolog + pop: true + prototype: + - match: '(%+).*\n?' + scope: comment.line.percentage.prolog + captures: + 1: punctuation.definition.comment.prolog + - match: '/\*(\*(?!/))?' + scope: comment.block.nested.prolog punctuation.definition.comment.prolog + push: nested-comment|0 + rule|0: + - match: '\(' + scope: punctuation.section.parens.begin.prolog + set: [rule|1, compound-term|0] + - match: ':-' + scope: keyword.operator.definition.begin.prolog + set: rule|2 + - match: '\.' + scope: keyword.operator.definition.end.prolog + pop: true + - match: '\S' + scope: invalid.illegal.prolog + pop: true + rule|1: + - match: ':-' + scope: keyword.operator.definition.begin.prolog + set: rule|2 + - match: '\.' + scope: keyword.operator.definition.end.prolog + pop: true + - match: '\S' + scope: invalid.illegal.prolog + pop: true + rule|2: + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: meta.path.prolog variable.function.functor.prolog + set: [rule|3, value|0, single-value|0] + - match: '''' + scope: meta.path.prolog variable.function.functor.prolog + set: [rule|3, value|0, single-value|0, atom-functor|meta, atom-string|0] + - match: '([~^&*\-+=|\\/<>][~^&*\-+=|\\/<>.,]*)(\()' + captures: + 1: constant.character.swi-prolog.prolog + 2: punctuation.section.parens.begin.prolog + set: [rule|3, value|0, operator-compound-term|0] + - match: '!' + scope: keyword.control.cut.prolog + set: [rule|3, value|0] + - match: '(0b)[01_]+' + scope: constant.numeric.integer.binary.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [rule|3, value|0] + - match: '(0x)[\h_]+' + scope: constant.numeric.integer.hexadecimal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [rule|3, value|0] + - match: '(0o)[0-7_]+' + scope: constant.numeric.integer.octal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [rule|3, value|0] + - match: '([0-9]{1,2})('')[0-9a-z]+' + scope: constant.numeric.integer.prolog + captures: + 1: punctuation.definition.number.base.prolog + 2: punctuation.separator.base.prolog + set: [rule|3, value|0] + - match: '[0-9]+\.[0-9]+' + scope: constant.numeric.float.prolog + set: [rule|3, value|0] + - match: '[+-]?[0-9_]+' + scope: constant.numeric.integer.prolog + set: [rule|3, value|0, number|0] + - match: '\b[A-Z][[:alpha:]0-9_]*\b|\b_[[:alpha:]0-9_]+\b' + scope: variable.parameter.prolog + set: [rule|3, value|0] + - match: '_' + scope: language.constant.underscore.prolog + set: [rule|3, value|0] + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.begin.prolog + set: [rule|3, value|0, string|0] + - match: '\[' + scope: punctuation.section.brackets.begin.prolog + set: [rule|3, value|0, list|0] + - match: '\{' + scope: punctuation.section.braces.begin.prolog + set: [rule|3, value|0, set|0] + - match: '\+|-' + scope: keyword.operator.arithmetic.prolog + set: [rule|3, value|0, single-value|1] + - match: '\\\+' + scope: keyword.control.negation.prolog + set: [rule|3, value|0, single-value|1] + - match: '\(' + scope: punctuation.section.group.begin.prolog + set: [rule|3, value|0, single-value|2] + - match: '\S' + scope: invalid.illegal.prolog + pop: true + rule|3: + - match: '\.' + scope: keyword.operator.definition.end.prolog + pop: true + - match: '\S' + scope: invalid.illegal.prolog + pop: true + set|0: + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: meta.path.prolog variable.function.functor.prolog + set: [set|1, value-without-comma|0, single-value|0] + - match: '''' + scope: meta.path.prolog variable.function.functor.prolog + set: [set|1, value-without-comma|0, single-value|0, atom-functor|meta, atom-string|0] + - match: '([~^&*\-+=|\\/<>][~^&*\-+=|\\/<>.,]*)(\()' + captures: + 1: constant.character.swi-prolog.prolog + 2: punctuation.section.parens.begin.prolog + set: [set|1, value-without-comma|0, operator-compound-term|0] + - match: '!' + scope: keyword.control.cut.prolog + set: [set|1, value-without-comma|0] + - match: '(0b)[01_]+' + scope: constant.numeric.integer.binary.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [set|1, value-without-comma|0] + - match: '(0x)[\h_]+' + scope: constant.numeric.integer.hexadecimal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [set|1, value-without-comma|0] + - match: '(0o)[0-7_]+' + scope: constant.numeric.integer.octal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [set|1, value-without-comma|0] + - match: '([0-9]{1,2})('')[0-9a-z]+' + scope: constant.numeric.integer.prolog + captures: + 1: punctuation.definition.number.base.prolog + 2: punctuation.separator.base.prolog + set: [set|1, value-without-comma|0] + - match: '[0-9]+\.[0-9]+' + scope: constant.numeric.float.prolog + set: [set|1, value-without-comma|0] + - match: '[+-]?[0-9_]+' + scope: constant.numeric.integer.prolog + set: [set|1, value-without-comma|0, number|0] + - match: '\b[A-Z][[:alpha:]0-9_]*\b|\b_[[:alpha:]0-9_]+\b' + scope: variable.parameter.prolog + set: [set|1, value-without-comma|0] + - match: '_' + scope: language.constant.underscore.prolog + set: [set|1, value-without-comma|0] + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.begin.prolog + set: [set|1, value-without-comma|0, string|0] + - match: '\[' + scope: punctuation.section.brackets.begin.prolog + set: [set|1, value-without-comma|0, list|0] + - match: '\{' + scope: punctuation.section.braces.begin.prolog + set: [set|1, value-without-comma|0, set|0] + - match: '\+|-' + scope: keyword.operator.arithmetic.prolog + set: [set|1, value-without-comma|0, single-value|1] + - match: '\\\+' + scope: keyword.control.negation.prolog + set: [set|1, value-without-comma|0, single-value|1] + - match: '\(' + scope: punctuation.section.group.begin.prolog + set: [set|1, value-without-comma|0, single-value|2] + - match: '\}' + scope: punctuation.section.braces.begin.prolog + pop: true + - match: '\S' + scope: invalid.illegal.prolog + pop: true + set|1: + - match: ',' + scope: punctuation.separator.sequence.prolog + push: set|2 + - match: '\}' + scope: punctuation.section.braces.begin.prolog + pop: true + - match: '\S' + scope: invalid.illegal.prolog + pop: true + set|2: + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: meta.path.prolog variable.function.functor.prolog + set: [value-without-comma|0, single-value|0] + - match: '''' + scope: meta.path.prolog variable.function.functor.prolog + set: [value-without-comma|0, single-value|0, atom-functor|meta, atom-string|0] + - match: '([~^&*\-+=|\\/<>][~^&*\-+=|\\/<>.,]*)(\()' + captures: + 1: constant.character.swi-prolog.prolog + 2: punctuation.section.parens.begin.prolog + set: [value-without-comma|0, operator-compound-term|0] + - match: '!' + scope: keyword.control.cut.prolog + set: value-without-comma|0 + - match: '(0b)[01_]+' + scope: constant.numeric.integer.binary.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: value-without-comma|0 + - match: '(0x)[\h_]+' + scope: constant.numeric.integer.hexadecimal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: value-without-comma|0 + - match: '(0o)[0-7_]+' + scope: constant.numeric.integer.octal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: value-without-comma|0 + - match: '([0-9]{1,2})('')[0-9a-z]+' + scope: constant.numeric.integer.prolog + captures: + 1: punctuation.definition.number.base.prolog + 2: punctuation.separator.base.prolog + set: value-without-comma|0 + - match: '[0-9]+\.[0-9]+' + scope: constant.numeric.float.prolog + set: value-without-comma|0 + - match: '[+-]?[0-9_]+' + scope: constant.numeric.integer.prolog + set: [value-without-comma|0, number|0] + - match: '\b[A-Z][[:alpha:]0-9_]*\b|\b_[[:alpha:]0-9_]+\b' + scope: variable.parameter.prolog + set: value-without-comma|0 + - match: '_' + scope: language.constant.underscore.prolog + set: value-without-comma|0 + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.begin.prolog + set: [value-without-comma|0, string|0] + - match: '\[' + scope: punctuation.section.brackets.begin.prolog + set: [value-without-comma|0, list|0] + - match: '\{' + scope: punctuation.section.braces.begin.prolog + set: [value-without-comma|0, set|0] + - match: '\+|-' + scope: keyword.operator.arithmetic.prolog + set: [value-without-comma|0, single-value|1] + - match: '\\\+' + scope: keyword.control.negation.prolog + set: [value-without-comma|0, single-value|1] + - match: '\(' + scope: punctuation.section.group.begin.prolog + set: [value-without-comma|0, single-value|2] + - match: '\S' + scope: invalid.illegal.prolog + pop: true + shebang|0: + - meta_content_scope: comment.line.number-sign.prolog + - match: '$\n?' + scope: comment.line.number-sign.prolog + pop: true + single-value|0: + - match: '\(' + scope: punctuation.section.parens.begin.prolog + set: compound-term|0 + - match: '(?=\S)' + pop: true + single-value|1: + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: meta.path.prolog variable.function.functor.prolog + set: single-value|0 + - match: '''' + scope: meta.path.prolog variable.function.functor.prolog + set: [single-value|0, atom-functor|meta, atom-string|0] + - match: '([~^&*\-+=|\\/<>][~^&*\-+=|\\/<>.,]*)(\()' + captures: + 1: constant.character.swi-prolog.prolog + 2: punctuation.section.parens.begin.prolog + set: operator-compound-term|0 + - match: '!' + scope: keyword.control.cut.prolog + pop: true + - match: '(0b)[01_]+' + scope: constant.numeric.integer.binary.prolog + captures: + 1: punctuation.definition.number.base.prolog + pop: true + - match: '(0x)[\h_]+' + scope: constant.numeric.integer.hexadecimal.prolog + captures: + 1: punctuation.definition.number.base.prolog + pop: true + - match: '(0o)[0-7_]+' + scope: constant.numeric.integer.octal.prolog + captures: + 1: punctuation.definition.number.base.prolog + pop: true + - match: '([0-9]{1,2})('')[0-9a-z]+' + scope: constant.numeric.integer.prolog + captures: + 1: punctuation.definition.number.base.prolog + 2: punctuation.separator.base.prolog + pop: true + - match: '[0-9]+\.[0-9]+' + scope: constant.numeric.float.prolog + pop: true + - match: '[+-]?[0-9_]+' + scope: constant.numeric.integer.prolog + set: number|0 + - match: '\b[A-Z][[:alpha:]0-9_]*\b|\b_[[:alpha:]0-9_]+\b' + scope: variable.parameter.prolog + pop: true + - match: '_' + scope: language.constant.underscore.prolog + pop: true + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.begin.prolog + set: string|0 + - match: '\[' + scope: punctuation.section.brackets.begin.prolog + set: list|0 + - match: '\{' + scope: punctuation.section.braces.begin.prolog + set: set|0 + - match: '\+|-' + scope: keyword.operator.arithmetic.prolog + set: single-value|1 + - match: '\\\+' + scope: keyword.control.negation.prolog + set: single-value|1 + - match: '\(' + scope: punctuation.section.group.begin.prolog + set: single-value|2 + - match: '\S' + scope: invalid.illegal.prolog + pop: true + single-value|2: + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: meta.path.prolog variable.function.functor.prolog + set: [single-value|3, value|0, single-value|0] + - match: '''' + scope: meta.path.prolog variable.function.functor.prolog + set: [single-value|3, value|0, single-value|0, atom-functor|meta, atom-string|0] + - match: '([~^&*\-+=|\\/<>][~^&*\-+=|\\/<>.,]*)(\()' + captures: + 1: constant.character.swi-prolog.prolog + 2: punctuation.section.parens.begin.prolog + set: [single-value|3, value|0, operator-compound-term|0] + - match: '!' + scope: keyword.control.cut.prolog + set: [single-value|3, value|0] + - match: '(0b)[01_]+' + scope: constant.numeric.integer.binary.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [single-value|3, value|0] + - match: '(0x)[\h_]+' + scope: constant.numeric.integer.hexadecimal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [single-value|3, value|0] + - match: '(0o)[0-7_]+' + scope: constant.numeric.integer.octal.prolog + captures: + 1: punctuation.definition.number.base.prolog + set: [single-value|3, value|0] + - match: '([0-9]{1,2})('')[0-9a-z]+' + scope: constant.numeric.integer.prolog + captures: + 1: punctuation.definition.number.base.prolog + 2: punctuation.separator.base.prolog + set: [single-value|3, value|0] + - match: '[0-9]+\.[0-9]+' + scope: constant.numeric.float.prolog + set: [single-value|3, value|0] + - match: '[+-]?[0-9_]+' + scope: constant.numeric.integer.prolog + set: [single-value|3, value|0, number|0] + - match: '\b[A-Z][[:alpha:]0-9_]*\b|\b_[[:alpha:]0-9_]+\b' + scope: variable.parameter.prolog + set: [single-value|3, value|0] + - match: '_' + scope: language.constant.underscore.prolog + set: [single-value|3, value|0] + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.begin.prolog + set: [single-value|3, value|0, string|0] + - match: '\[' + scope: punctuation.section.brackets.begin.prolog + set: [single-value|3, value|0, list|0] + - match: '\{' + scope: punctuation.section.braces.begin.prolog + set: [single-value|3, value|0, set|0] + - match: '\+|-' + scope: keyword.operator.arithmetic.prolog + set: [single-value|3, value|0, single-value|1] + - match: '\\\+' + scope: keyword.control.negation.prolog + set: [single-value|3, value|0, single-value|1] + - match: '\(' + scope: punctuation.section.group.begin.prolog + set: [single-value|3, value|0, single-value|2] + - match: '\S' + scope: invalid.illegal.prolog + pop: true + single-value|3: + - match: '\)' + scope: punctuation.section.group.end.prolog + pop: true + - match: '\S' + scope: invalid.illegal.prolog + pop: true + string|0: + - meta_content_scope: meta.string.prolog string.quoted.double.prolog + - meta_include_prototype: false + - match: '\\([abcefnrstv''\"`\n\\]|x\h\h+\\?|u\h{4}|U\h{8})' + scope: constant.character.escape.prolog + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.end.prolog + pop: true + value-without-comma|0: + - match: '\bis\b|>>|\^|=\.\.|=?<|>=?|==?|\*\*?|\+|->?|/|#=|\\=' + scope: keyword.operator.prolog + push: value-without-comma|1 + - match: ';' + scope: keyword.operator.logical.or.prolog + push: value-without-comma|1 + - match: '->' + scope: keyword.operator.logical.if.prolog + push: value-without-comma|1 + - match: '(?=\S)' + pop: true + value-without-comma|1: + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: meta.path.prolog variable.function.functor.prolog + set: single-value|0 + - match: '''' + scope: meta.path.prolog variable.function.functor.prolog + set: [single-value|0, atom-functor|meta, atom-string|0] + - match: '([~^&*\-+=|\\/<>][~^&*\-+=|\\/<>.,]*)(\()' + captures: + 1: constant.character.swi-prolog.prolog + 2: punctuation.section.parens.begin.prolog + set: operator-compound-term|0 + - match: '!' + scope: keyword.control.cut.prolog + pop: true + - match: '(0b)[01_]+' + scope: constant.numeric.integer.binary.prolog + captures: + 1: punctuation.definition.number.base.prolog + pop: true + - match: '(0x)[\h_]+' + scope: constant.numeric.integer.hexadecimal.prolog + captures: + 1: punctuation.definition.number.base.prolog + pop: true + - match: '(0o)[0-7_]+' + scope: constant.numeric.integer.octal.prolog + captures: + 1: punctuation.definition.number.base.prolog + pop: true + - match: '([0-9]{1,2})('')[0-9a-z]+' + scope: constant.numeric.integer.prolog + captures: + 1: punctuation.definition.number.base.prolog + 2: punctuation.separator.base.prolog + pop: true + - match: '[0-9]+\.[0-9]+' + scope: constant.numeric.float.prolog + pop: true + - match: '[+-]?[0-9_]+' + scope: constant.numeric.integer.prolog + set: number|0 + - match: '\b[A-Z][[:alpha:]0-9_]*\b|\b_[[:alpha:]0-9_]+\b' + scope: variable.parameter.prolog + pop: true + - match: '_' + scope: language.constant.underscore.prolog + pop: true + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.begin.prolog + set: string|0 + - match: '\[' + scope: punctuation.section.brackets.begin.prolog + set: list|0 + - match: '\{' + scope: punctuation.section.braces.begin.prolog + set: set|0 + - match: '\+|-' + scope: keyword.operator.arithmetic.prolog + set: single-value|1 + - match: '\\\+' + scope: keyword.control.negation.prolog + set: single-value|1 + - match: '\(' + scope: punctuation.section.group.begin.prolog + set: single-value|2 + - match: '\S' + scope: invalid.illegal.prolog + pop: true + value|0: + - match: '\bis\b|>>|\^|=\.\.|=?<|>=?|==?|\*\*?|\+|->?|/|#=|\\=' + scope: keyword.operator.prolog + push: value|1 + - match: ';' + scope: keyword.operator.logical.or.prolog + push: value|1 + - match: '->' + scope: keyword.operator.logical.if.prolog + push: value|1 + - match: ',' + scope: keyword.operator.logical.and.prolog + push: value|1 + - match: '(?=\S)' + pop: true + value|1: + - match: '\b[a-z][[:alpha:]0-9_]*\b' + scope: meta.path.prolog variable.function.functor.prolog + set: single-value|0 + - match: '''' + scope: meta.path.prolog variable.function.functor.prolog + set: [single-value|0, atom-functor|meta, atom-string|0] + - match: '([~^&*\-+=|\\/<>][~^&*\-+=|\\/<>.,]*)(\()' + captures: + 1: constant.character.swi-prolog.prolog + 2: punctuation.section.parens.begin.prolog + set: operator-compound-term|0 + - match: '!' + scope: keyword.control.cut.prolog + pop: true + - match: '(0b)[01_]+' + scope: constant.numeric.integer.binary.prolog + captures: + 1: punctuation.definition.number.base.prolog + pop: true + - match: '(0x)[\h_]+' + scope: constant.numeric.integer.hexadecimal.prolog + captures: + 1: punctuation.definition.number.base.prolog + pop: true + - match: '(0o)[0-7_]+' + scope: constant.numeric.integer.octal.prolog + captures: + 1: punctuation.definition.number.base.prolog + pop: true + - match: '([0-9]{1,2})('')[0-9a-z]+' + scope: constant.numeric.integer.prolog + captures: + 1: punctuation.definition.number.base.prolog + 2: punctuation.separator.base.prolog + pop: true + - match: '[0-9]+\.[0-9]+' + scope: constant.numeric.float.prolog + pop: true + - match: '[+-]?[0-9_]+' + scope: constant.numeric.integer.prolog + set: number|0 + - match: '\b[A-Z][[:alpha:]0-9_]*\b|\b_[[:alpha:]0-9_]+\b' + scope: variable.parameter.prolog + pop: true + - match: '_' + scope: language.constant.underscore.prolog + pop: true + - match: '"' + scope: meta.string.prolog string.quoted.double.prolog punctuation.definition.string.begin.prolog + set: string|0 + - match: '\[' + scope: punctuation.section.brackets.begin.prolog + set: list|0 + - match: '\{' + scope: punctuation.section.braces.begin.prolog + set: set|0 + - match: '\+|-' + scope: keyword.operator.arithmetic.prolog + set: single-value|1 + - match: '\\\+' + scope: keyword.control.negation.prolog + set: single-value|1 + - match: '\(' + scope: punctuation.section.group.begin.prolog + set: single-value|2 + - match: '\S' + scope: invalid.illegal.prolog + pop: true diff --git a/third_party/bat_syntaxes/default.nix b/third_party/bat_syntaxes/default.nix new file mode 100644 index 0000000000..15af130916 --- /dev/null +++ b/third_party/bat_syntaxes/default.nix @@ -0,0 +1,18 @@ +# For depot projects that make use of syntect (primarily +# //tools/cheddar) the included syntax set is taken from bat. +# +# However, bat lacks some of the syntaxes we are interested in. This +# package creates a new binary syntax set which bundles our additional +# syntaxes on top of bat's existing ones. +{ pkgs, ... }: + +let + inherit (pkgs) bat runCommand; +in +runCommand "bat-syntaxes.bin" { } '' + export HOME=$PWD + mkdir -p .config/bat/syntaxes + cp ${./Prolog.sublime-syntax} .config/bat/syntaxes + ${bat}/bin/bat cache --build + mv .cache/bat/syntaxes.bin $out +'' diff --git a/third_party/cgit/.gitignore b/third_party/cgit/.gitignore new file mode 100644 index 0000000000..661df346c2 --- /dev/null +++ b/third_party/cgit/.gitignore @@ -0,0 +1,12 @@ +# Files I don't care to see in git-status/commit +/cgit +cgit.conf +CGIT-CFLAGS +VERSION +cgitrc.5 +cgitrc.5.fo +cgitrc.5.html +cgitrc.5.pdf +cgitrc.5.xml +*.o +*.d diff --git a/third_party/cgit/.mailmap b/third_party/cgit/.mailmap new file mode 100644 index 0000000000..03b54796cf --- /dev/null +++ b/third_party/cgit/.mailmap @@ -0,0 +1,10 @@ +Florian Pritz <bluewind@xinu.at> <bluewind@xssn.at> +Harley Laue <losinggeneration@gmail.com> <losinggeneration@aim.com> +John Keeping <john@keeping.me.uk> <john@metanate.com> +Lars Hjemli <hjemli@gmail.com> <larsh@hal-2004.(none)> +Lars Hjemli <hjemli@gmail.com> <larsh@hatman.(none)> +Lars Hjemli <hjemli@gmail.com> <larsh@slackbox.hjemli.net> +Lars Hjemli <hjemli@gmail.com> <larsh@slaptop.hjemli.net> +Lukas Fleischer <lfleischer@lfos.de> <cgit@cryptocrack.de> +Lukas Fleischer <lfleischer@lfos.de> <info@cryptocrack.de> +Stefan Bühler <source@stbuehler.de> <lighttpd@stbuehler.de> diff --git a/third_party/cgit/.skip-subtree b/third_party/cgit/.skip-subtree new file mode 100644 index 0000000000..c108a7d34f --- /dev/null +++ b/third_party/cgit/.skip-subtree @@ -0,0 +1 @@ +Subtrees of this directory belong to cgit (third-party). diff --git a/third_party/cgit/AUTHORS b/third_party/cgit/AUTHORS new file mode 100644 index 0000000000..256ea6b3bc --- /dev/null +++ b/third_party/cgit/AUTHORS @@ -0,0 +1,13 @@ +Maintainer: + June McEnroe <june@causal.agency> + +Contributors: + Jason A. Donenfeld <Jason@zx2c4.com> + Lukas Fleischer <cgit@cryptocrack.de> + Johan Herland <johan@herland.net> + Lars Hjemli <hjemli@gmail.com> + Ferry Huberts <ferry.huberts@pelagic.nl> + John Keeping <john@keeping.me.uk> + +Previous Maintainer: + Lars Hjemli <hjemli@gmail.com> diff --git a/third_party/cgit/COPYING b/third_party/cgit/COPYING new file mode 100644 index 0000000000..d159169d10 --- /dev/null +++ b/third_party/cgit/COPYING @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + <one line to give the program's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + <signature of Ty Coon>, 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/third_party/cgit/Makefile b/third_party/cgit/Makefile new file mode 100644 index 0000000000..1a7f1f6381 --- /dev/null +++ b/third_party/cgit/Makefile @@ -0,0 +1,168 @@ +all:: + +CGIT_VERSION = 1.4.1 +CGIT_SCRIPT_NAME = cgit.cgi +CGIT_SCRIPT_PATH = /var/www/htdocs/cgit +CGIT_DATA_PATH = $(CGIT_SCRIPT_PATH) +CGIT_CONFIG = /etc/cgitrc +CACHE_ROOT = /var/cache/cgit +prefix = /usr/local +libdir = $(prefix)/lib +filterdir = $(libdir)/cgit/filters +docdir = $(prefix)/share/doc/cgit +htmldir = $(docdir) +pdfdir = $(docdir) +mandir = $(prefix)/share/man +SHA1_HEADER = <openssl/sha.h> +GIT_VER = 2.41.0 +GIT_URL = https://www.kernel.org/pub/software/scm/git/git-$(GIT_VER).tar.xz +INSTALL = install +COPYTREE = cp -r +MAN5_TXT = $(wildcard *.5.txt) +MAN_TXT = $(MAN5_TXT) +DOC_MAN5 = $(patsubst %.txt,%,$(MAN5_TXT)) +DOC_HTML = $(patsubst %.txt,%.html,$(MAN_TXT)) +DOC_PDF = $(patsubst %.txt,%.pdf,$(MAN_TXT)) + +ASCIIDOC = asciidoc +ASCIIDOC_EXTRA = +ASCIIDOC_HTML = xhtml11 +ASCIIDOC_COMMON = $(ASCIIDOC) $(ASCIIDOC_EXTRA) +TXT_TO_HTML = $(ASCIIDOC_COMMON) -b $(ASCIIDOC_HTML) + +# Define NO_C99_FORMAT if your formatted IO functions (printf/scanf et.al.) +# do not support the 'size specifiers' introduced by C99, namely ll, hh, +# j, z, t. (representing long long int, char, intmax_t, size_t, ptrdiff_t). +# some C compilers supported these specifiers prior to C99 as an extension. +# +# Define HAVE_LINUX_SENDFILE to use sendfile() + +#-include config.mak + +-include git/config.mak.uname +# +# Let the user override the above settings. +# +-include cgit.conf + +export CGIT_VERSION CGIT_SCRIPT_NAME CGIT_SCRIPT_PATH CGIT_DATA_PATH CGIT_CONFIG CACHE_ROOT + +# +# Define a way to invoke make in subdirs quietly, shamelessly ripped +# from git.git +# +QUIET_SUBDIR0 = +$(MAKE) -C # space to separate -C and subdir +QUIET_SUBDIR1 = + +ifneq ($(findstring w,$(MAKEFLAGS)),w) +PRINT_DIR = --no-print-directory +else # "make -w" +NO_SUBDIR = : +endif + +ifndef V + QUIET_SUBDIR0 = +@subdir= + QUIET_SUBDIR1 = ;$(NO_SUBDIR) echo ' ' SUBDIR $$subdir; \ + $(MAKE) $(PRINT_DIR) -C $$subdir + QUIET_TAGS = @echo ' ' TAGS $@; + export V +endif + +.SUFFIXES: + +all:: cgit + +cgit: + $(QUIET_SUBDIR0)git $(QUIET_SUBDIR1) -f ../cgit.mk ../cgit $(EXTRA_GIT_TARGETS) NO_CURL=1 + +sparse: + $(QUIET_SUBDIR0)git $(QUIET_SUBDIR1) -f ../cgit.mk NO_CURL=1 cgit-sparse + +test: + @$(MAKE) --no-print-directory cgit EXTRA_GIT_TARGETS=all + $(QUIET_SUBDIR0)tests $(QUIET_SUBDIR1) all + +install: all + $(INSTALL) -m 0755 -d $(DESTDIR)$(CGIT_SCRIPT_PATH) + $(INSTALL) -m 0755 cgit $(DESTDIR)$(CGIT_SCRIPT_PATH)/$(CGIT_SCRIPT_NAME) + $(INSTALL) -m 0755 -d $(DESTDIR)$(CGIT_DATA_PATH) + $(INSTALL) -m 0644 cgit.css $(DESTDIR)$(CGIT_DATA_PATH)/cgit.css + $(INSTALL) -m 0644 cgit.png $(DESTDIR)$(CGIT_DATA_PATH)/cgit.png + $(INSTALL) -m 0644 robots.txt $(DESTDIR)$(CGIT_DATA_PATH)/robots.txt + $(INSTALL) -m 0755 -d $(DESTDIR)$(filterdir) + $(COPYTREE) filters/* $(DESTDIR)$(filterdir) + +install-doc: install-man install-html install-pdf + +install-man: doc-man + $(INSTALL) -m 0755 -d $(DESTDIR)$(mandir)/man5 + $(INSTALL) -m 0644 $(DOC_MAN5) $(DESTDIR)$(mandir)/man5 + +install-html: doc-html + $(INSTALL) -m 0755 -d $(DESTDIR)$(htmldir) + $(INSTALL) -m 0644 $(DOC_HTML) $(DESTDIR)$(htmldir) + +install-pdf: doc-pdf + $(INSTALL) -m 0755 -d $(DESTDIR)$(pdfdir) + $(INSTALL) -m 0644 $(DOC_PDF) $(DESTDIR)$(pdfdir) + +uninstall: + rm -f $(DESTDIR)$(CGIT_SCRIPT_PATH)/$(CGIT_SCRIPT_NAME) + rm -f $(DESTDIR)$(CGIT_DATA_PATH)/cgit.css + rm -f $(DESTDIR)$(CGIT_DATA_PATH)/cgit.png + +uninstall-doc: uninstall-man uninstall-html uninstall-pdf + +uninstall-man: + @for i in $(DOC_MAN5); do \ + rm -fv $(DESTDIR)$(mandir)/man5/$$i; \ + done + +uninstall-html: + @for i in $(DOC_HTML); do \ + rm -fv $(DESTDIR)$(htmldir)/$$i; \ + done + +uninstall-pdf: + @for i in $(DOC_PDF); do \ + rm -fv $(DESTDIR)$(pdfdir)/$$i; \ + done + +doc: doc-man doc-html doc-pdf +doc-man: doc-man5 +doc-man5: $(DOC_MAN5) +doc-html: $(DOC_HTML) +doc-pdf: $(DOC_PDF) + +%.5 : %.5.txt + a2x -f manpage $< + +$(DOC_HTML): %.html : %.txt + $(TXT_TO_HTML) -o $@+ $< && \ + mv $@+ $@ + +$(DOC_PDF): %.pdf : %.txt + a2x -f pdf cgitrc.5.txt + +clean: clean-doc + $(RM) cgit VERSION CGIT-CFLAGS *.o tags + $(RM) -r .deps + +cleanall: clean + $(MAKE) -C git clean + +clean-doc: + $(RM) cgitrc.5 cgitrc.5.html cgitrc.5.pdf cgitrc.5.xml cgitrc.5.fo + +get-git: + curl -L $(GIT_URL) | tar -xJf - && rm -rf git && mv git-$(GIT_VER) git + +tags: + $(QUIET_TAGS)find . -name '*.[ch]' | xargs ctags + +.PHONY: all cgit git get-git +.PHONY: clean clean-doc cleanall +.PHONY: doc doc-html doc-man doc-pdf +.PHONY: install install-doc install-html install-man install-pdf +.PHONY: tags test +.PHONY: uninstall uninstall-doc uninstall-html uninstall-man uninstall-pdf diff --git a/third_party/cgit/README b/third_party/cgit/README new file mode 100644 index 0000000000..2094b87df0 --- /dev/null +++ b/third_party/cgit/README @@ -0,0 +1,88 @@ +cgit-pink - CGI for Git +======================= + +This is a fork of cgit, an attempt to create a fast web interface +for the Git SCM, using a built-in cache to decrease server I/O +pressure. + +Installation +------------ + +Building cgit involves building a proper version of Git. How to do this +depends on how you obtained the cgit sources: + +a) If you're working in a cloned cgit repository, you first need to +initialize and update the Git submodule: + + $ git submodule init # register the Git submodule in .git/config + $ $EDITOR .git/config # if you want to specify a different url for git + $ git submodule update # clone/fetch and checkout correct git version + +b) If you're building from a cgit tarball, you can download a proper git +version like this: + + $ make get-git + +When either a) or b) has been performed, you can build and install cgit like +this: + + $ make + $ sudo make install + +This will install `cgit.cgi` and `cgit.css` into `/var/www/htdocs/cgit`. You +can configure this location (and a few other things) by providing a `cgit.conf` +file (see the Makefile for details). + + +Dependencies +------------ + +* libzip +* libcrypto (OpenSSL) +* libssl (OpenSSL) + +Apache configuration +-------------------- + +A new `Directory` section must probably be added for cgit, possibly something +like this: + + <Directory "/var/www/htdocs/cgit/"> + AllowOverride None + Options +ExecCGI + Order allow,deny + Allow from all + </Directory> + + +Runtime configuration +--------------------- + +The file `/etc/cgitrc` is read by cgit before handling a request. In addition +to runtime parameters, this file may also contain a list of repositories +displayed by cgit (see `cgitrc.5.txt` for further details). + +The cache +--------- + +When cgit is invoked it looks for a cache file matching the request and +returns it to the client. If no such cache file exists (or if it has expired), +the content for the request is written into the proper cache file before the +file is returned. + +If the cache file has expired but cgit is unable to obtain a lock for it, the +stale cache file is returned to the client. This is done to favour page +throughput over page freshness. + +The generated content contains the complete response to the client, including +the HTTP headers `Modified` and `Expires`. + +Online presence +--------------- + +* The cgit-pink homepage is hosted by cgit at + <https://git.causal.agency/cgit-pink/about> + +* Patches, bug reports, discussions and support should go to the cgit-pink + mailing list: <list+cgit@causal.agency>. Archives are available at: + <https://causal.agency/list/cgit.html> diff --git a/third_party/cgit/cache.c b/third_party/cgit/cache.c new file mode 100644 index 0000000000..59372541cb --- /dev/null +++ b/third_party/cgit/cache.c @@ -0,0 +1,480 @@ +/* cache.c: cache management + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + * + * + * The cache is just a directory structure where each file is a cache slot, + * and each filename is based on the hash of some key (e.g. the cgit url). + * Each file contains the full key followed by the cached content for that + * key. + * + */ + +#include "cgit.h" +#include "cache.h" +#include "html.h" +#ifdef HAVE_LINUX_SENDFILE +#include <sys/sendfile.h> +#endif + +#define CACHE_BUFSIZE (1024 * 4) + +struct cache_slot { + const char *key; + size_t keylen; + int ttl; + cache_fill_fn fn; + int cache_fd; + int lock_fd; + int stdout_fd; + const char *cache_name; + const char *lock_name; + int match; + struct stat cache_st; + int bufsize; + char buf[CACHE_BUFSIZE]; +}; + +/* Open an existing cache slot and fill the cache buffer with + * (part of) the content of the cache file. Return 0 on success + * and errno otherwise. + */ +static int open_slot(struct cache_slot *slot) +{ + char *bufz; + ssize_t bufkeylen = -1; + + slot->cache_fd = open(slot->cache_name, O_RDONLY); + if (slot->cache_fd == -1) + return errno; + + if (fstat(slot->cache_fd, &slot->cache_st)) + return errno; + + slot->bufsize = xread(slot->cache_fd, slot->buf, sizeof(slot->buf)); + if (slot->bufsize < 0) + return errno; + + bufz = memchr(slot->buf, 0, slot->bufsize); + if (bufz) + bufkeylen = bufz - slot->buf; + + if (slot->key) + slot->match = bufkeylen == slot->keylen && + !memcmp(slot->key, slot->buf, bufkeylen + 1); + + return 0; +} + +/* Close the active cache slot */ +static int close_slot(struct cache_slot *slot) +{ + int err = 0; + if (slot->cache_fd > 0) { + if (close(slot->cache_fd)) + err = errno; + else + slot->cache_fd = -1; + } + return err; +} + +/* Print the content of the active cache slot (but skip the key). */ +static int print_slot(struct cache_slot *slot) +{ + off_t off; +#ifdef HAVE_LINUX_SENDFILE + off_t size; +#endif + + off = slot->keylen + 1; + +#ifdef HAVE_LINUX_SENDFILE + size = slot->cache_st.st_size; + + do { + ssize_t ret; + ret = sendfile(STDOUT_FILENO, slot->cache_fd, &off, size - off); + if (ret < 0) { + if (errno == EAGAIN || errno == EINTR) + continue; + /* Fall back to read/write on EINVAL or ENOSYS */ + if (errno == EINVAL || errno == ENOSYS) + break; + return errno; + } + if (off == size) + return 0; + } while (1); +#endif + + if (lseek(slot->cache_fd, off, SEEK_SET) != off) + return errno; + + do { + ssize_t ret; + ret = xread(slot->cache_fd, slot->buf, sizeof(slot->buf)); + if (ret < 0) + return errno; + if (ret == 0) + return 0; + if (write_in_full(STDOUT_FILENO, slot->buf, ret) < 0) + return errno; + } while (1); +} + +/* Check if the slot has expired */ +static int is_expired(struct cache_slot *slot) +{ + if (slot->ttl < 0) + return 0; + else + return slot->cache_st.st_mtime + slot->ttl * 60 < time(NULL); +} + +/* Check if the slot has been modified since we opened it. + * NB: If stat() fails, we pretend the file is modified. + */ +static int is_modified(struct cache_slot *slot) +{ + struct stat st; + + if (stat(slot->cache_name, &st)) + return 1; + return (st.st_ino != slot->cache_st.st_ino || + st.st_mtime != slot->cache_st.st_mtime || + st.st_size != slot->cache_st.st_size); +} + +/* Close an open lockfile */ +static int close_lock(struct cache_slot *slot) +{ + int err = 0; + if (slot->lock_fd > 0) { + if (close(slot->lock_fd)) + err = errno; + else + slot->lock_fd = -1; + } + return err; +} + +/* Create a lockfile used to store the generated content for a cache + * slot, and write the slot key + \0 into it. + * Returns 0 on success and errno otherwise. + */ +static int lock_slot(struct cache_slot *slot) +{ + struct flock lock = { + .l_type = F_WRLCK, + .l_whence = SEEK_SET, + .l_start = 0, + .l_len = 0, + }; + + slot->lock_fd = open(slot->lock_name, O_RDWR | O_CREAT, + S_IRUSR | S_IWUSR); + if (slot->lock_fd == -1) + return errno; + if (fcntl(slot->lock_fd, F_SETLK, &lock) < 0) { + int saved_errno = errno; + close(slot->lock_fd); + slot->lock_fd = -1; + return saved_errno; + } + if (xwrite(slot->lock_fd, slot->key, slot->keylen + 1) < 0) + return errno; + return 0; +} + +/* Release the current lockfile. If `replace_old_slot` is set the + * lockfile replaces the old cache slot, otherwise the lockfile is + * just deleted. + */ +static int unlock_slot(struct cache_slot *slot, int replace_old_slot) +{ + int err; + + if (replace_old_slot) + err = rename(slot->lock_name, slot->cache_name); + else + err = unlink(slot->lock_name); + + /* Restore stdout and close the temporary FD. */ + if (slot->stdout_fd >= 0) { + dup2(slot->stdout_fd, STDOUT_FILENO); + close(slot->stdout_fd); + slot->stdout_fd = -1; + } + + if (err) + return errno; + + return 0; +} + +/* Generate the content for the current cache slot by redirecting + * stdout to the lock-fd and invoking the callback function + */ +static int fill_slot(struct cache_slot *slot) +{ + /* Preserve stdout */ + slot->stdout_fd = dup(STDOUT_FILENO); + if (slot->stdout_fd == -1) + return errno; + + /* Redirect stdout to lockfile */ + if (dup2(slot->lock_fd, STDOUT_FILENO) == -1) + return errno; + + /* Generate cache content */ + slot->fn(); + + /* Make sure any buffered data is flushed to the file */ + if (fflush(stdout)) + return errno; + + /* update stat info */ + if (fstat(slot->lock_fd, &slot->cache_st)) + return errno; + + return 0; +} + +/* Crude implementation of 32-bit FNV-1 hash algorithm, + * see http://www.isthe.com/chongo/tech/comp/fnv/ for details + * about the magic numbers. + */ +#define FNV_OFFSET 0x811c9dc5 +#define FNV_PRIME 0x01000193 + +unsigned long hash_str(const char *str) +{ + unsigned long h = FNV_OFFSET; + unsigned char *s = (unsigned char *)str; + + if (!s) + return h; + + while (*s) { + h *= FNV_PRIME; + h ^= *s++; + } + return h; +} + +static int process_slot(struct cache_slot *slot) +{ + int err; + + /* + * Make sure any buffered data is flushed before we redirect, + * do sendfile(2) or write(2) + */ + if (fflush(stdout)) + return errno; + + err = open_slot(slot); + if (!err && slot->match) { + if (is_expired(slot)) { + if (!lock_slot(slot)) { + /* If the cachefile has been replaced between + * `open_slot` and `lock_slot`, we'll just + * serve the stale content from the original + * cachefile. This way we avoid pruning the + * newly generated slot. The same code-path + * is chosen if fill_slot() fails for some + * reason. + * + * TODO? check if the new slot contains the + * same key as the old one, since we would + * prefer to serve the newest content. + * This will require us to open yet another + * file-descriptor and read and compare the + * key from the new file, so for now we're + * lazy and just ignore the new file. + */ + if (is_modified(slot) || fill_slot(slot)) { + unlock_slot(slot, 0); + close_lock(slot); + } else { + close_slot(slot); + unlock_slot(slot, 1); + slot->cache_fd = slot->lock_fd; + } + } + } + if ((err = print_slot(slot)) != 0) { + cache_log("[cgit] error printing cache %s: %s (%d)\n", + slot->cache_name, + strerror(err), + err); + } + close_slot(slot); + return err; + } + + /* If the cache slot does not exist (or its key doesn't match the + * current key), lets try to create a new cache slot for this + * request. If this fails (for whatever reason), lets just generate + * the content without caching it and fool the caller to believe + * everything worked out (but print a warning on stdout). + */ + + close_slot(slot); + if ((err = lock_slot(slot)) != 0) { + cache_log("[cgit] Unable to lock slot %s: %s (%d)\n", + slot->lock_name, strerror(err), err); + slot->fn(); + return 0; + } + + if ((err = fill_slot(slot)) != 0) { + cache_log("[cgit] Unable to fill slot %s: %s (%d)\n", + slot->lock_name, strerror(err), err); + unlock_slot(slot, 0); + close_lock(slot); + slot->fn(); + return 0; + } + // We've got a valid cache slot in the lock file, which + // is about to replace the old cache slot. But if we + // release the lockfile and then try to open the new cache + // slot, we might get a race condition with a concurrent + // writer for the same cache slot (with a different key). + // Lets avoid such a race by just printing the content of + // the lock file. + slot->cache_fd = slot->lock_fd; + unlock_slot(slot, 1); + if ((err = print_slot(slot)) != 0) { + cache_log("[cgit] error printing cache %s: %s (%d)\n", + slot->cache_name, + strerror(err), + err); + } + close_slot(slot); + return err; +} + +/* Print cached content to stdout, generate the content if necessary. */ +int cache_process(int size, const char *path, const char *key, int ttl, + cache_fill_fn fn) +{ + unsigned long hash; + int i; + struct strbuf filename = STRBUF_INIT; + struct strbuf lockname = STRBUF_INIT; + struct cache_slot slot; + int result; + + /* If the cache is disabled, just generate the content */ + if (size <= 0 || ttl == 0) { + fn(); + return 0; + } + + /* Verify input, calculate filenames */ + if (!path) { + cache_log("[cgit] Cache path not specified, caching is disabled\n"); + fn(); + return 0; + } + if (!key) + key = ""; + hash = hash_str(key) % size; + strbuf_addstr(&filename, path); + strbuf_ensure_end(&filename, '/'); + for (i = 0; i < 8; i++) { + strbuf_addf(&filename, "%x", (unsigned char)(hash & 0xf)); + hash >>= 4; + } + strbuf_addbuf(&lockname, &filename); + strbuf_addstr(&lockname, ".lock"); + slot.fn = fn; + slot.ttl = ttl; + slot.stdout_fd = -1; + slot.cache_name = filename.buf; + slot.lock_name = lockname.buf; + slot.key = key; + slot.keylen = strlen(key); + result = process_slot(&slot); + + strbuf_release(&filename); + strbuf_release(&lockname); + return result; +} + +/* Return a strftime formatted date/time + * NB: the result from this function is to shared memory + */ +static char *sprintftime(const char *format, time_t time) +{ + static char buf[64]; + struct tm tm; + + if (!time) + return NULL; + gmtime_r(&time, &tm); + strftime(buf, sizeof(buf)-1, format, &tm); + return buf; +} + +int cache_ls(const char *path) +{ + DIR *dir; + struct dirent *ent; + int err = 0; + struct cache_slot slot = { NULL }; + struct strbuf fullname = STRBUF_INIT; + size_t prefixlen; + + if (!path) { + cache_log("[cgit] cache path not specified\n"); + return -1; + } + dir = opendir(path); + if (!dir) { + err = errno; + cache_log("[cgit] unable to open path %s: %s (%d)\n", + path, strerror(err), err); + return err; + } + strbuf_addstr(&fullname, path); + strbuf_ensure_end(&fullname, '/'); + prefixlen = fullname.len; + while ((ent = readdir(dir)) != NULL) { + if (strlen(ent->d_name) != 8) + continue; + strbuf_setlen(&fullname, prefixlen); + strbuf_addstr(&fullname, ent->d_name); + slot.cache_name = fullname.buf; + if ((err = open_slot(&slot)) != 0) { + cache_log("[cgit] unable to open path %s: %s (%d)\n", + fullname.buf, strerror(err), err); + continue; + } + htmlf("%s %s %10"PRIuMAX" %s\n", + fullname.buf, + sprintftime("%Y-%m-%d %H:%M:%S", + slot.cache_st.st_mtime), + (uintmax_t)slot.cache_st.st_size, + slot.buf); + close_slot(&slot); + } + closedir(dir); + strbuf_release(&fullname); + return 0; +} + +/* Print a message to stdout */ +void cache_log(const char *format, ...) +{ + va_list args; + va_start(args, format); + vfprintf(stderr, format, args); + va_end(args); +} + diff --git a/third_party/cgit/cache.h b/third_party/cgit/cache.h new file mode 100644 index 0000000000..470da4fc15 --- /dev/null +++ b/third_party/cgit/cache.h @@ -0,0 +1,37 @@ +/* + * Since git has it's own cache.h which we include, + * lets test on CGIT_CACHE_H to avoid confusion + */ + +#ifndef CGIT_CACHE_H +#define CGIT_CACHE_H + +typedef void (*cache_fill_fn)(void); + + +/* Print cached content to stdout, generate the content if necessary. + * + * Parameters + * size max number of cache files + * path directory used to store cache files + * key the key used to lookup cache files + * ttl max cache time in seconds for this key + * fn content generator function for this key + * + * Return value + * 0 indicates success, everything else is an error + */ +extern int cache_process(int size, const char *path, const char *key, int ttl, + cache_fill_fn fn); + + +/* List info about all cache entries on stdout */ +extern int cache_ls(const char *path); + +/* Print a message to stdout */ +__attribute__((format (printf,1,2))) +extern void cache_log(const char *format, ...); + +extern unsigned long hash_str(const char *str); + +#endif /* CGIT_CACHE_H */ diff --git a/third_party/cgit/cgit.c b/third_party/cgit/cgit.c new file mode 100644 index 0000000000..40202ead67 --- /dev/null +++ b/third_party/cgit/cgit.c @@ -0,0 +1,1107 @@ +/* cgit.c: cgi for the git scm + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "cache.h" +#include "cmd.h" +#include "configfile.h" +#include "html.h" +#include "ui-shared.h" +#include "ui-stats.h" +#include "ui-blob.h" +#include "ui-summary.h" +#include "scan-tree.h" + +const char *cgit_version = CGIT_VERSION; + +__attribute__((constructor)) +static void constructor_environment() +{ + /* Do not look in /etc/ for gitconfig and gitattributes. */ + setenv("GIT_CONFIG_NOSYSTEM", "1", 1); + setenv("GIT_ATTR_NOSYSTEM", "1", 1); + unsetenv("HOME"); + unsetenv("XDG_CONFIG_HOME"); +} + +static void add_mimetype(const char *name, const char *value) +{ + struct string_list_item *item; + + item = string_list_insert(&ctx.cfg.mimetypes, name); + item->util = xstrdup(value); +} + +static void process_cached_repolist(const char *path); + +static void repo_config(struct cgit_repo *repo, const char *name, const char *value) +{ + const char *path; + struct string_list_item *item; + + if (!strcmp(name, "name")) + repo->name = xstrdup(value); + else if (!strcmp(name, "clone-url")) + repo->clone_url = xstrdup(value); + else if (!strcmp(name, "desc")) + repo->desc = xstrdup(value); + else if (!strcmp(name, "owner")) + repo->owner = xstrdup(value); + else if (!strcmp(name, "homepage")) + repo->homepage = xstrdup(value); + else if (!strcmp(name, "defbranch")) + repo->defbranch = xstrdup(value); + else if (!strcmp(name, "extra-head-content")) + repo->extra_head_content = xstrdup(value); + else if (!strcmp(name, "snapshots")) + repo->snapshots = ctx.cfg.snapshots & cgit_parse_snapshots_mask(value); + else if (!strcmp(name, "enable-blame")) + repo->enable_blame = atoi(value); + else if (!strcmp(name, "enable-commit-graph")) + repo->enable_commit_graph = atoi(value); + else if (!strcmp(name, "enable-log-filecount")) + repo->enable_log_filecount = atoi(value); + else if (!strcmp(name, "enable-log-linecount")) + repo->enable_log_linecount = atoi(value); + else if (!strcmp(name, "enable-remote-branches")) + repo->enable_remote_branches = atoi(value); + else if (!strcmp(name, "enable-subject-links")) + repo->enable_subject_links = atoi(value); + else if (!strcmp(name, "enable-html-serving")) + repo->enable_html_serving = atoi(value); + else if (!strcmp(name, "branch-sort")) { + if (!strcmp(value, "age")) + repo->branch_sort = 1; + if (!strcmp(value, "name")) + repo->branch_sort = 0; + } else if (!strcmp(name, "commit-sort")) { + if (!strcmp(value, "date")) + repo->commit_sort = 1; + if (!strcmp(value, "topo")) + repo->commit_sort = 2; + } else if (!strcmp(name, "max-stats")) + repo->max_stats = cgit_find_stats_period(value, NULL); + else if (!strcmp(name, "module-link")) + repo->module_link= xstrdup(value); + else if (skip_prefix(name, "module-link.", &path)) { + item = string_list_append(&repo->submodules, xstrdup(path)); + item->util = xstrdup(value); + } else if (!strcmp(name, "section")) + repo->section = xstrdup(value); + else if (!strcmp(name, "snapshot-prefix")) + repo->snapshot_prefix = xstrdup(value); + else if (!strcmp(name, "readme") && value != NULL) { + if (repo->readme.items == ctx.cfg.readme.items) + memset(&repo->readme, 0, sizeof(repo->readme)); + string_list_append(&repo->readme, xstrdup(value)); + } else if (!strcmp(name, "logo") && value != NULL) + repo->logo = xstrdup(value); + else if (!strcmp(name, "logo-link") && value != NULL) + repo->logo_link = xstrdup(value); + else if (!strcmp(name, "hide")) + repo->hide = atoi(value); + else if (!strcmp(name, "ignore")) + repo->ignore = atoi(value); + else if (ctx.cfg.enable_filter_overrides) { + if (!strcmp(name, "about-filter")) + repo->about_filter = cgit_new_filter(value, ABOUT); + else if (!strcmp(name, "commit-filter")) + repo->commit_filter = cgit_new_filter(value, COMMIT); + else if (!strcmp(name, "source-filter")) + repo->source_filter = cgit_new_filter(value, SOURCE); + else if (!strcmp(name, "email-filter")) + repo->email_filter = cgit_new_filter(value, EMAIL); + else if (!strcmp(name, "owner-filter")) + repo->owner_filter = cgit_new_filter(value, OWNER); + } +} + +static void config_cb(const char *name, const char *value) +{ + const char *arg; + + if (!strcmp(name, "section")) + ctx.cfg.section = xstrdup(value); + else if (!strcmp(name, "repo.url")) + ctx.repo = cgit_add_repo(value); + else if (ctx.repo && !strcmp(name, "repo.path")) + ctx.repo->path = trim_end(value, '/'); + else if (ctx.repo && skip_prefix(name, "repo.", &arg)) + repo_config(ctx.repo, arg, value); + else if (!strcmp(name, "readme")) + string_list_append(&ctx.cfg.readme, xstrdup(value)); + else if (!strcmp(name, "root-title")) + ctx.cfg.root_title = xstrdup(value); + else if (!strcmp(name, "root-desc")) + ctx.cfg.root_desc = xstrdup(value); + else if (!strcmp(name, "root-readme")) + ctx.cfg.root_readme = xstrdup(value); + else if (!strcmp(name, "css")) + ctx.cfg.css = xstrdup(value); + else if (!strcmp(name, "favicon")) + ctx.cfg.favicon = xstrdup(value); + else if (!strcmp(name, "footer")) + ctx.cfg.footer = xstrdup(value); + else if (!strcmp(name, "head-include")) + ctx.cfg.head_include = xstrdup(value); + else if (!strcmp(name, "header")) + ctx.cfg.header = xstrdup(value); + else if (!strcmp(name, "logo")) + ctx.cfg.logo = xstrdup(value); + else if (!strcmp(name, "logo-link")) + ctx.cfg.logo_link = xstrdup(value); + else if (!strcmp(name, "module-link")) + ctx.cfg.module_link = xstrdup(value); + else if (!strcmp(name, "strict-export")) + ctx.cfg.strict_export = xstrdup(value); + else if (!strcmp(name, "virtual-root")) + ctx.cfg.virtual_root = ensure_end(value, '/'); + else if (!strcmp(name, "noplainemail")) + ctx.cfg.noplainemail = atoi(value); + else if (!strcmp(name, "noheader")) + ctx.cfg.noheader = atoi(value); + else if (!strcmp(name, "snapshots")) + ctx.cfg.snapshots = cgit_parse_snapshots_mask(value); + else if (!strcmp(name, "enable-filter-overrides")) + ctx.cfg.enable_filter_overrides = atoi(value); + else if (!strcmp(name, "enable-follow-links")) + ctx.cfg.enable_follow_links = atoi(value); + else if (!strcmp(name, "enable-http-clone")) + ctx.cfg.enable_http_clone = atoi(value); + else if (!strcmp(name, "enable-index-links")) + ctx.cfg.enable_index_links = atoi(value); + else if (!strcmp(name, "enable-index-owner")) + ctx.cfg.enable_index_owner = atoi(value); + else if (!strcmp(name, "enable-blame")) + ctx.cfg.enable_blame = atoi(value); + else if (!strcmp(name, "enable-commit-graph")) + ctx.cfg.enable_commit_graph = atoi(value); + else if (!strcmp(name, "enable-log-filecount")) + ctx.cfg.enable_log_filecount = atoi(value); + else if (!strcmp(name, "enable-log-linecount")) + ctx.cfg.enable_log_linecount = atoi(value); + else if (!strcmp(name, "enable-remote-branches")) + ctx.cfg.enable_remote_branches = atoi(value); + else if (!strcmp(name, "enable-subject-links")) + ctx.cfg.enable_subject_links = atoi(value); + else if (!strcmp(name, "enable-html-serving")) + ctx.cfg.enable_html_serving = atoi(value); + else if (!strcmp(name, "enable-tree-linenumbers")) + ctx.cfg.enable_tree_linenumbers = atoi(value); + else if (!strcmp(name, "enable-git-config")) + ctx.cfg.enable_git_config = atoi(value); + else if (!strcmp(name, "max-stats")) + ctx.cfg.max_stats = cgit_find_stats_period(value, NULL); + else if (!strcmp(name, "cache-size")) + ctx.cfg.cache_size = atoi(value); + else if (!strcmp(name, "cache-root")) + ctx.cfg.cache_root = xstrdup(expand_macros(value)); + else if (!strcmp(name, "cache-root-ttl")) + ctx.cfg.cache_root_ttl = atoi(value); + else if (!strcmp(name, "cache-repo-ttl")) + ctx.cfg.cache_repo_ttl = atoi(value); + else if (!strcmp(name, "cache-scanrc-ttl")) + ctx.cfg.cache_scanrc_ttl = atoi(value); + else if (!strcmp(name, "cache-static-ttl")) + ctx.cfg.cache_static_ttl = atoi(value); + else if (!strcmp(name, "cache-dynamic-ttl")) + ctx.cfg.cache_dynamic_ttl = atoi(value); + else if (!strcmp(name, "cache-about-ttl")) + ctx.cfg.cache_about_ttl = atoi(value); + else if (!strcmp(name, "cache-snapshot-ttl")) + ctx.cfg.cache_snapshot_ttl = atoi(value); + else if (!strcmp(name, "case-sensitive-sort")) + ctx.cfg.case_sensitive_sort = atoi(value); + else if (!strcmp(name, "about-filter")) + ctx.cfg.about_filter = cgit_new_filter(value, ABOUT); + else if (!strcmp(name, "commit-filter")) + ctx.cfg.commit_filter = cgit_new_filter(value, COMMIT); + else if (!strcmp(name, "email-filter")) + ctx.cfg.email_filter = cgit_new_filter(value, EMAIL); + else if (!strcmp(name, "owner-filter")) + ctx.cfg.owner_filter = cgit_new_filter(value, OWNER); + else if (!strcmp(name, "auth-filter")) + ctx.cfg.auth_filter = cgit_new_filter(value, AUTH); + else if (!strcmp(name, "embedded")) + ctx.cfg.embedded = atoi(value); + else if (!strcmp(name, "max-atom-items")) + ctx.cfg.max_atom_items = atoi(value); + else if (!strcmp(name, "max-message-length")) + ctx.cfg.max_msg_len = atoi(value); + else if (!strcmp(name, "max-repodesc-length")) + ctx.cfg.max_repodesc_len = atoi(value); + else if (!strcmp(name, "max-blob-size")) + ctx.cfg.max_blob_size = atoi(value); + else if (!strcmp(name, "max-repo-count")) + ctx.cfg.max_repo_count = atoi(value); + else if (!strcmp(name, "max-commit-count")) + ctx.cfg.max_commit_count = atoi(value); + else if (!strcmp(name, "project-list")) + ctx.cfg.project_list = xstrdup(expand_macros(value)); + else if (!strcmp(name, "scan-path")) + if (ctx.cfg.cache_size) + process_cached_repolist(expand_macros(value)); + else if (ctx.cfg.project_list) + scan_projects(expand_macros(value), + ctx.cfg.project_list, repo_config); + else + scan_tree(expand_macros(value), repo_config); + else if (!strcmp(name, "scan-hidden-path")) + ctx.cfg.scan_hidden_path = atoi(value); + else if (!strcmp(name, "section-from-path")) + ctx.cfg.section_from_path = atoi(value); + else if (!strcmp(name, "repository-sort")) + ctx.cfg.repository_sort = xstrdup(value); + else if (!strcmp(name, "section-sort")) + ctx.cfg.section_sort = atoi(value); + else if (!strcmp(name, "source-filter")) + ctx.cfg.source_filter = cgit_new_filter(value, SOURCE); + else if (!strcmp(name, "summary-log")) + ctx.cfg.summary_log = atoi(value); + else if (!strcmp(name, "summary-branches")) + ctx.cfg.summary_branches = atoi(value); + else if (!strcmp(name, "summary-tags")) + ctx.cfg.summary_tags = atoi(value); + else if (!strcmp(name, "side-by-side-diffs")) + ctx.cfg.difftype = atoi(value) ? DIFF_SSDIFF : DIFF_UNIFIED; + else if (!strcmp(name, "agefile")) + ctx.cfg.agefile = xstrdup(value); + else if (!strcmp(name, "mimetype-file")) + ctx.cfg.mimetype_file = xstrdup(value); + else if (!strcmp(name, "renamelimit")) + ctx.cfg.renamelimit = atoi(value); + else if (!strcmp(name, "remove-suffix")) + ctx.cfg.remove_suffix = atoi(value); + else if (!strcmp(name, "robots")) + ctx.cfg.robots = xstrdup(value); + else if (!strcmp(name, "clone-prefix")) + ctx.cfg.clone_prefix = xstrdup(value); + else if (!strcmp(name, "clone-url")) + ctx.cfg.clone_url = xstrdup(value); + else if (!strcmp(name, "local-time")) + ctx.cfg.local_time = atoi(value); + else if (!strcmp(name, "commit-sort")) { + if (!strcmp(value, "date")) + ctx.cfg.commit_sort = 1; + if (!strcmp(value, "topo")) + ctx.cfg.commit_sort = 2; + } else if (!strcmp(name, "branch-sort")) { + if (!strcmp(value, "age")) + ctx.cfg.branch_sort = 1; + if (!strcmp(value, "name")) + ctx.cfg.branch_sort = 0; + } else if (skip_prefix(name, "mimetype.", &arg)) + add_mimetype(arg, value); + else if (!strcmp(name, "include")) + parse_configfile(expand_macros(value), config_cb); +} + +static void querystring_cb(const char *name, const char *value) +{ + if (!value) + value = ""; + + if (!strcmp(name,"r")) { + ctx.qry.repo = xstrdup(value); + ctx.repo = cgit_get_repoinfo(value); + } else if (!strcmp(name, "p")) { + ctx.qry.page = xstrdup(value); + } else if (!strcmp(name, "url")) { + if (*value == '/') + value++; + ctx.qry.url = xstrdup(value); + cgit_parse_url(value); + } else if (!strcmp(name, "qt")) { + ctx.qry.grep = xstrdup(value); + } else if (!strcmp(name, "q")) { + ctx.qry.search = xstrdup(value); + } else if (!strcmp(name, "h")) { + ctx.qry.head = xstrdup(value); + ctx.qry.has_symref = 1; + } else if (!strcmp(name, "id")) { + ctx.qry.oid = xstrdup(value); + ctx.qry.has_oid = 1; + } else if (!strcmp(name, "id2")) { + ctx.qry.oid2 = xstrdup(value); + ctx.qry.has_oid = 1; + } else if (!strcmp(name, "ofs")) { + ctx.qry.ofs = atoi(value); + } else if (!strcmp(name, "path")) { + ctx.qry.path = trim_end(value, '/'); + } else if (!strcmp(name, "name")) { + ctx.qry.name = xstrdup(value); + } else if (!strcmp(name, "s")) { + ctx.qry.sort = xstrdup(value); + } else if (!strcmp(name, "showmsg")) { + ctx.qry.showmsg = atoi(value); + } else if (!strcmp(name, "period")) { + ctx.qry.period = xstrdup(value); + } else if (!strcmp(name, "dt")) { + ctx.qry.difftype = atoi(value); + ctx.qry.has_difftype = 1; + } else if (!strcmp(name, "ss")) { + /* No longer generated, but there may be links out there. */ + ctx.qry.difftype = atoi(value) ? DIFF_SSDIFF : DIFF_UNIFIED; + ctx.qry.has_difftype = 1; + } else if (!strcmp(name, "all")) { + ctx.qry.show_all = atoi(value); + } else if (!strcmp(name, "context")) { + ctx.qry.context = atoi(value); + } else if (!strcmp(name, "ignorews")) { + ctx.qry.ignorews = atoi(value); + } else if (!strcmp(name, "follow")) { + ctx.qry.follow = atoi(value); + } +} + +static void prepare_context(void) +{ + memset(&ctx, 0, sizeof(ctx)); + ctx.cfg.agefile = "info/web/last-modified"; + ctx.cfg.cache_size = 0; + ctx.cfg.cache_max_create_time = 5; + ctx.cfg.cache_root = CGIT_CACHE_ROOT; + ctx.cfg.cache_about_ttl = 15; + ctx.cfg.cache_snapshot_ttl = 5; + ctx.cfg.cache_repo_ttl = 5; + ctx.cfg.cache_root_ttl = 5; + ctx.cfg.cache_scanrc_ttl = 15; + ctx.cfg.cache_dynamic_ttl = 5; + ctx.cfg.cache_static_ttl = -1; + ctx.cfg.case_sensitive_sort = 1; + ctx.cfg.branch_sort = 0; + ctx.cfg.commit_sort = 0; + ctx.cfg.css = "/cgit.css"; + ctx.cfg.logo = "/cgit.png"; + ctx.cfg.favicon = NULL; + ctx.cfg.local_time = 0; + ctx.cfg.enable_http_clone = 1; + ctx.cfg.enable_index_owner = 1; + ctx.cfg.enable_tree_linenumbers = 1; + ctx.cfg.enable_git_config = 0; + ctx.cfg.max_repo_count = 50; + ctx.cfg.max_commit_count = 50; + ctx.cfg.max_lock_attempts = 5; + ctx.cfg.max_msg_len = 80; + ctx.cfg.max_repodesc_len = 80; + ctx.cfg.max_blob_size = 0; + ctx.cfg.max_stats = 0; + ctx.cfg.project_list = NULL; + ctx.cfg.renamelimit = -1; + ctx.cfg.remove_suffix = 0; + ctx.cfg.robots = "index, nofollow"; + ctx.cfg.root_title = "Git repository browser"; + ctx.cfg.root_desc = "a fast webinterface for the git dscm"; + ctx.cfg.scan_hidden_path = 0; + ctx.cfg.script_name = CGIT_SCRIPT_NAME; + ctx.cfg.section = ""; + ctx.cfg.repository_sort = "name"; + ctx.cfg.section_sort = 1; + ctx.cfg.summary_branches = 10; + ctx.cfg.summary_log = 10; + ctx.cfg.summary_tags = 10; + ctx.cfg.max_atom_items = 10; + ctx.cfg.difftype = DIFF_UNIFIED; + ctx.env.cgit_config = getenv("CGIT_CONFIG"); + ctx.env.http_host = getenv("HTTP_HOST"); + ctx.env.https = getenv("HTTPS"); + ctx.env.no_http = getenv("NO_HTTP"); + ctx.env.path_info = getenv("PATH_INFO"); + ctx.env.query_string = getenv("QUERY_STRING"); + ctx.env.request_method = getenv("REQUEST_METHOD"); + ctx.env.script_name = getenv("SCRIPT_NAME"); + ctx.env.server_name = getenv("SERVER_NAME"); + ctx.env.server_port = getenv("SERVER_PORT"); + ctx.env.http_cookie = getenv("HTTP_COOKIE"); + ctx.env.http_referer = getenv("HTTP_REFERER"); + ctx.env.content_length = getenv("CONTENT_LENGTH") ? strtoul(getenv("CONTENT_LENGTH"), NULL, 10) : 0; + ctx.env.authenticated = 0; + ctx.page.mimetype = "text/html"; + ctx.page.charset = PAGE_ENCODING; + ctx.page.filename = NULL; + ctx.page.size = 0; + ctx.page.modified = time(NULL); + ctx.page.expires = ctx.page.modified; + ctx.page.etag = NULL; + string_list_init_dup(&ctx.cfg.mimetypes); + if (ctx.env.script_name) + ctx.cfg.script_name = xstrdup(ctx.env.script_name); + if (ctx.env.query_string) + ctx.qry.raw = xstrdup(ctx.env.query_string); + if (!ctx.env.cgit_config) + ctx.env.cgit_config = CGIT_CONFIG; +} + +struct refmatch { + char *req_ref; + char *first_ref; + int match; +}; + +static int find_current_ref(const char *refname, const struct object_id *oid, + int flags, void *cb_data) +{ + struct refmatch *info; + + info = (struct refmatch *)cb_data; + if (!strcmp(refname, info->req_ref)) + info->match = 1; + if (!info->first_ref) + info->first_ref = xstrdup(refname); + return info->match; +} + +static void free_refmatch_inner(struct refmatch *info) +{ + if (info->first_ref) + free(info->first_ref); +} + +static char *find_default_branch(struct cgit_repo *repo) +{ + struct refmatch info; + char *ref; + + info.req_ref = repo->defbranch; + info.first_ref = NULL; + info.match = 0; + for_each_branch_ref(find_current_ref, &info); + if (info.match) + ref = info.req_ref; + else + ref = info.first_ref; + if (ref) + ref = xstrdup(ref); + free_refmatch_inner(&info); + + return ref; +} + +static char *guess_defbranch(void) +{ + const char *ref, *refname; + struct object_id oid; + + ref = resolve_ref_unsafe("HEAD", 0, &oid, NULL); + if (!ref || !skip_prefix(ref, "refs/heads/", &refname)) + return "master"; + return xstrdup(refname); +} + +/* The caller must free filename and ref after calling this. */ +static inline void parse_readme(const char *readme, char **filename, char **ref, struct cgit_repo *repo) +{ + const char *colon; + + *filename = NULL; + *ref = NULL; + + if (!readme || !readme[0]) + return; + + /* Check if the readme is tracked in the git repo. */ + colon = strchr(readme, ':'); + if (colon && strlen(colon) > 1) { + /* If it starts with a colon, we want to use head given + * from query or the default branch */ + if (colon == readme && ctx.qry.head) + *ref = xstrdup(ctx.qry.head); + else if (colon == readme && repo->defbranch) + *ref = xstrdup(repo->defbranch); + else + *ref = xstrndup(readme, colon - readme); + readme = colon + 1; + } + + /* Prepend repo path to relative readme path unless tracked. */ + if (!(*ref) && readme[0] != '/') + *filename = fmtalloc("%s/%s", repo->path, readme); + else + *filename = xstrdup(readme); +} +static void choose_readme(struct cgit_repo *repo) +{ + int found; + char *filename, *ref; + struct string_list_item *entry; + + if (!repo->readme.nr) + return; + + found = 0; + for_each_string_list_item(entry, &repo->readme) { + parse_readme(entry->string, &filename, &ref, repo); + if (!filename) { + free(filename); + free(ref); + continue; + } + if (ref) { + if (cgit_ref_path_exists(filename, ref, 1)) { + found = 1; + break; + } + } + else if (!access(filename, R_OK)) { + found = 1; + break; + } + free(filename); + free(ref); + } + repo->readme.strdup_strings = 1; + string_list_clear(&repo->readme, 0); + repo->readme.strdup_strings = 0; + if (found) + string_list_append(&repo->readme, filename)->util = ref; +} + +static void print_no_repo_clone_urls(const char *url) +{ + html("<tr><td><a rel='vcs-git' href='"); + html_url_path(url); + html("' title='"); + html_attr(ctx.repo->name); + html(" Git repository'>"); + html_txt(url); + html("</a></td></tr>\n"); +} + +static void prepare_repo_env(int *nongit) +{ + /* The path to the git repository. */ + setenv("GIT_DIR", ctx.repo->path, 1); + + /* Setup the git directory and initialize the notes system. Both of these + * load local configuration from the git repository, so we do them both while + * the HOME variables are unset. */ + setup_git_directory_gently(nongit); + load_display_notes(NULL); +} + +static int prepare_repo_cmd(int nongit) +{ + struct object_id oid; + int rc; + + if (nongit) { + const char *name = ctx.repo->name; + rc = errno; + ctx.page.title = fmtalloc("%s - %s", ctx.cfg.root_title, + "config error"); + ctx.repo = NULL; + cgit_print_http_headers(); + cgit_print_docstart(); + cgit_print_pageheader(); + cgit_print_error("Failed to open %s: %s", name, + rc ? strerror(rc) : "Not a valid git repository"); + cgit_print_docend(); + return 1; + } + ctx.page.title = fmtalloc("%s - %s", ctx.repo->name, ctx.repo->desc); + + if (!ctx.repo->defbranch) + ctx.repo->defbranch = guess_defbranch(); + + if (!ctx.qry.head) { + ctx.qry.nohead = 1; + ctx.qry.head = find_default_branch(ctx.repo); + } + + if (!ctx.qry.head) { + cgit_print_http_headers(); + cgit_print_docstart(); + cgit_print_pageheader(); + cgit_print_error("Repository seems to be empty"); + if (!strcmp(ctx.qry.page, "summary")) { + html("<table class='list'><tr class='nohover'><td> </td></tr><tr class='nohover'><th class='left'>Clone</th></tr>\n"); + cgit_prepare_repo_env(ctx.repo); + cgit_add_clone_urls(print_no_repo_clone_urls); + html("</table>\n"); + } + cgit_print_docend(); + return 1; + } + + if (repo_get_oid(the_repository, ctx.qry.head, &oid)) { + char *old_head = ctx.qry.head; + ctx.qry.head = xstrdup(ctx.repo->defbranch); + cgit_print_error_page(404, "Not found", + "Invalid branch: %s", old_head); + free(old_head); + return 1; + } + string_list_sort(&ctx.repo->submodules); + cgit_prepare_repo_env(ctx.repo); + choose_readme(ctx.repo); + return 0; +} + +static inline void open_auth_filter(const char *function) +{ + cgit_open_filter(ctx.cfg.auth_filter, function, + ctx.env.http_cookie ? ctx.env.http_cookie : "", + ctx.env.request_method ? ctx.env.request_method : "", + ctx.env.query_string ? ctx.env.query_string : "", + ctx.env.http_referer ? ctx.env.http_referer : "", + ctx.env.path_info ? ctx.env.path_info : "", + ctx.env.http_host ? ctx.env.http_host : "", + ctx.env.https ? ctx.env.https : "", + ctx.qry.repo ? ctx.qry.repo : "", + ctx.qry.page ? ctx.qry.page : "", + cgit_currentfullurl(), + cgit_loginurl()); +} + +/* We intentionally keep this rather small, instead of looping and + * feeding it to the filter a couple bytes at a time. This way, the + * filter itself does not need to handle any denial of service or + * buffer bloat issues. If this winds up being too small, people + * will complain on the mailing list, and we'll increase it as needed. */ +#define MAX_AUTHENTICATION_POST_BYTES 4096 +/* The filter is expected to spit out "Status: " and all headers. */ +static inline void authenticate_post(void) +{ + char buffer[MAX_AUTHENTICATION_POST_BYTES]; + ssize_t len; + + open_auth_filter("authenticate-post"); + len = ctx.env.content_length; + if (len > MAX_AUTHENTICATION_POST_BYTES) + len = MAX_AUTHENTICATION_POST_BYTES; + if ((len = read(STDIN_FILENO, buffer, len)) < 0) + die_errno("Could not read POST from stdin"); + if (fwrite(buffer, 1, len, stdout) < len) + die_errno("Could not write POST to stdout"); + cgit_close_filter(ctx.cfg.auth_filter); + exit(0); +} + +static inline void authenticate_cookie(void) +{ + /* If we don't have an auth_filter, consider all cookies valid, and thus return early. */ + if (!ctx.cfg.auth_filter) { + ctx.env.authenticated = 1; + return; + } + + /* If we're having something POST'd to /login, we're authenticating POST, + * instead of the cookie, so call authenticate_post and bail out early. + * This pattern here should match /?p=login with POST. */ + if (ctx.env.request_method && ctx.qry.page && !ctx.repo && \ + !strcmp(ctx.env.request_method, "POST") && !strcmp(ctx.qry.page, "login")) { + authenticate_post(); + return; + } + + /* If we've made it this far, we're authenticating the cookie for real, so do that. */ + open_auth_filter("authenticate-cookie"); + ctx.env.authenticated = cgit_close_filter(ctx.cfg.auth_filter); +} + +static void process_request(void) +{ + struct cgit_cmd *cmd; + int nongit = 0; + + /* If we're not yet authenticated, no matter what page we're on, + * display the authentication body from the auth_filter. This should + * never be cached. */ + if (!ctx.env.authenticated) { + ctx.page.title = "Authentication Required"; + cgit_print_http_headers(); + cgit_print_docstart(); + cgit_print_pageheader(); + open_auth_filter("body"); + cgit_close_filter(ctx.cfg.auth_filter); + cgit_print_docend(); + return; + } + + if (ctx.repo) + prepare_repo_env(&nongit); + + cmd = cgit_get_cmd(); + if (!cmd) { + ctx.page.title = "cgit error"; + cgit_print_error_page(404, "Not found", "Invalid request"); + return; + } + + if (!ctx.cfg.enable_http_clone && cmd->is_clone) { + ctx.page.title = "cgit error"; + cgit_print_error_page(404, "Not found", "Invalid request"); + return; + } + + if (cmd->want_repo && !ctx.repo) { + cgit_print_error_page(400, "Bad request", + "No repository selected"); + return; + } + + /* If cmd->want_vpath is set, assume ctx.qry.path contains a "virtual" + * in-project path limit to be made available at ctx.qry.vpath. + * Otherwise, no path limit is in effect (ctx.qry.vpath = NULL). + */ + ctx.qry.vpath = cmd->want_vpath ? ctx.qry.path : NULL; + + if (ctx.repo && prepare_repo_cmd(nongit)) + return; + + cmd->fn(); +} + +static int cmp_repos(const void *a, const void *b) +{ + const struct cgit_repo *ra = a, *rb = b; + return strcmp(ra->url, rb->url); +} + +static char *build_snapshot_setting(int bitmap) +{ + const struct cgit_snapshot_format *f; + struct strbuf result = STRBUF_INIT; + + for (f = cgit_snapshot_formats; f->suffix; f++) { + if (cgit_snapshot_format_bit(f) & bitmap) { + if (result.len) + strbuf_addch(&result, ' '); + strbuf_addstr(&result, f->suffix); + } + } + return strbuf_detach(&result, NULL); +} + +static char *get_first_line(char *txt) +{ + char *t = xstrdup(txt); + char *p = strchr(t, '\n'); + if (p) + *p = '\0'; + return t; +} + +static void print_repo(FILE *f, struct cgit_repo *repo) +{ + struct string_list_item *item; + fprintf(f, "repo.url=%s\n", repo->url); + fprintf(f, "repo.name=%s\n", repo->name); + fprintf(f, "repo.path=%s\n", repo->path); + if (repo->owner) + fprintf(f, "repo.owner=%s\n", repo->owner); + if (repo->desc) { + char *tmp = get_first_line(repo->desc); + fprintf(f, "repo.desc=%s\n", tmp); + free(tmp); + } + for_each_string_list_item(item, &repo->readme) { + if (item->util) + fprintf(f, "repo.readme=%s:%s\n", (char *)item->util, item->string); + else + fprintf(f, "repo.readme=%s\n", item->string); + } + if (repo->defbranch) + fprintf(f, "repo.defbranch=%s\n", repo->defbranch); + if (repo->extra_head_content) + fprintf(f, "repo.extra-head-content=%s\n", repo->extra_head_content); + if (repo->module_link) + fprintf(f, "repo.module-link=%s\n", repo->module_link); + if (repo->section) + fprintf(f, "repo.section=%s\n", repo->section); + if (repo->homepage) + fprintf(f, "repo.homepage=%s\n", repo->homepage); + if (repo->clone_url) + fprintf(f, "repo.clone-url=%s\n", repo->clone_url); + fprintf(f, "repo.enable-blame=%d\n", + repo->enable_blame); + fprintf(f, "repo.enable-commit-graph=%d\n", + repo->enable_commit_graph); + fprintf(f, "repo.enable-log-filecount=%d\n", + repo->enable_log_filecount); + fprintf(f, "repo.enable-log-linecount=%d\n", + repo->enable_log_linecount); + if (repo->about_filter && repo->about_filter != ctx.cfg.about_filter) + cgit_fprintf_filter(repo->about_filter, f, "repo.about-filter="); + if (repo->commit_filter && repo->commit_filter != ctx.cfg.commit_filter) + cgit_fprintf_filter(repo->commit_filter, f, "repo.commit-filter="); + if (repo->source_filter && repo->source_filter != ctx.cfg.source_filter) + cgit_fprintf_filter(repo->source_filter, f, "repo.source-filter="); + if (repo->email_filter && repo->email_filter != ctx.cfg.email_filter) + cgit_fprintf_filter(repo->email_filter, f, "repo.email-filter="); + if (repo->owner_filter && repo->owner_filter != ctx.cfg.owner_filter) + cgit_fprintf_filter(repo->owner_filter, f, "repo.owner-filter="); + if (repo->snapshots != ctx.cfg.snapshots) { + char *tmp = build_snapshot_setting(repo->snapshots); + fprintf(f, "repo.snapshots=%s\n", tmp ? tmp : ""); + free(tmp); + } + if (repo->snapshot_prefix) + fprintf(f, "repo.snapshot-prefix=%s\n", repo->snapshot_prefix); + if (repo->max_stats != ctx.cfg.max_stats) + fprintf(f, "repo.max-stats=%s\n", + cgit_find_stats_periodname(repo->max_stats)); + if (repo->logo) + fprintf(f, "repo.logo=%s\n", repo->logo); + if (repo->logo_link) + fprintf(f, "repo.logo-link=%s\n", repo->logo_link); + fprintf(f, "repo.enable-remote-branches=%d\n", repo->enable_remote_branches); + fprintf(f, "repo.enable-subject-links=%d\n", repo->enable_subject_links); + fprintf(f, "repo.enable-html-serving=%d\n", repo->enable_html_serving); + if (repo->branch_sort == 1) + fprintf(f, "repo.branch-sort=age\n"); + if (repo->commit_sort) { + if (repo->commit_sort == 1) + fprintf(f, "repo.commit-sort=date\n"); + else if (repo->commit_sort == 2) + fprintf(f, "repo.commit-sort=topo\n"); + } + fprintf(f, "repo.hide=%d\n", repo->hide); + fprintf(f, "repo.ignore=%d\n", repo->ignore); + fprintf(f, "\n"); +} + +static void print_repolist(FILE *f, struct cgit_repolist *list, int start) +{ + int i; + + for (i = start; i < list->count; i++) + print_repo(f, &list->repos[i]); +} + +/* Scan 'path' for git repositories, save the resulting repolist in 'cached_rc' + * and return 0 on success. + */ +static int generate_cached_repolist(const char *path, const char *cached_rc) +{ + struct strbuf locked_rc = STRBUF_INIT; + int result = 0; + int idx; + FILE *f; + + strbuf_addf(&locked_rc, "%s.lock", cached_rc); + f = fopen(locked_rc.buf, "wx"); + if (!f) { + /* Inform about the error unless the lockfile already existed, + * since that only means we've got concurrent requests. + */ + result = errno; + if (result != EEXIST) + fprintf(stderr, "[cgit] Error opening %s: %s (%d)\n", + locked_rc.buf, strerror(result), result); + goto out; + } + idx = cgit_repolist.count; + if (ctx.cfg.project_list) + scan_projects(path, ctx.cfg.project_list, repo_config); + else + scan_tree(path, repo_config); + print_repolist(f, &cgit_repolist, idx); + if (rename(locked_rc.buf, cached_rc)) + fprintf(stderr, "[cgit] Error renaming %s to %s: %s (%d)\n", + locked_rc.buf, cached_rc, strerror(errno), errno); + fclose(f); +out: + strbuf_release(&locked_rc); + return result; +} + +static void process_cached_repolist(const char *path) +{ + struct stat st; + struct strbuf cached_rc = STRBUF_INIT; + time_t age; + unsigned long hash; + + hash = hash_str(path); + if (ctx.cfg.project_list) + hash += hash_str(ctx.cfg.project_list); + strbuf_addf(&cached_rc, "%s/rc-%8lx", ctx.cfg.cache_root, hash); + + if (stat(cached_rc.buf, &st)) { + /* Nothing is cached, we need to scan without forking. And + * if we fail to generate a cached repolist, we need to + * invoke scan_tree manually. + */ + if (generate_cached_repolist(path, cached_rc.buf)) { + if (ctx.cfg.project_list) + scan_projects(path, ctx.cfg.project_list, + repo_config); + else + scan_tree(path, repo_config); + } + goto out; + } + + parse_configfile(cached_rc.buf, config_cb); + + /* If the cached configfile hasn't expired, lets exit now */ + age = time(NULL) - st.st_mtime; + if (age <= (ctx.cfg.cache_scanrc_ttl * 60)) + goto out; + + /* The cached repolist has been parsed, but it was old. So lets + * rescan the specified path and generate a new cached repolist + * in a child-process to avoid latency for the current request. + */ + if (fork()) + goto out; + + exit(generate_cached_repolist(path, cached_rc.buf)); +out: + strbuf_release(&cached_rc); +} + +static void cgit_parse_args(int argc, const char **argv) +{ + int i; + const char *arg; + int scan = 0; + + for (i = 1; i < argc; i++) { + if (!strcmp(argv[i], "--version")) { + printf("CGit-pink %s | https://git.causal.agency/cgit-pink/\n\nCompiled in features:\n", CGIT_VERSION); +#ifndef HAVE_LINUX_SENDFILE + printf("[-] "); +#else + printf("[+] "); +#endif + printf("Linux sendfile() usage\n"); + + exit(0); + } + if (skip_prefix(argv[i], "--cache=", &arg)) { + ctx.cfg.cache_root = xstrdup(arg); + } else if (!strcmp(argv[i], "--nohttp")) { + ctx.env.no_http = "1"; + } else if (skip_prefix(argv[i], "--query=", &arg)) { + ctx.qry.raw = xstrdup(arg); + } else if (skip_prefix(argv[i], "--repo=", &arg)) { + ctx.qry.repo = xstrdup(arg); + } else if (skip_prefix(argv[i], "--page=", &arg)) { + ctx.qry.page = xstrdup(arg); + } else if (skip_prefix(argv[i], "--head=", &arg)) { + ctx.qry.head = xstrdup(arg); + ctx.qry.has_symref = 1; + } else if (skip_prefix(argv[i], "--oid=", &arg)) { + ctx.qry.oid = xstrdup(arg); + ctx.qry.has_oid = 1; + } else if (skip_prefix(argv[i], "--ofs=", &arg)) { + ctx.qry.ofs = atoi(arg); + } else if (skip_prefix(argv[i], "--scan-tree=", &arg) || + skip_prefix(argv[i], "--scan-path=", &arg)) { + /* + * HACK: The global snapshot bit mask defines the set + * of allowed snapshot formats, but the config file + * hasn't been parsed yet so the mask is currently 0. + * By setting all bits high before scanning we make + * sure that any in-repo cgitrc snapshot setting is + * respected by scan_tree(). + * + * NOTE: We assume that there aren't more than 8 + * different snapshot formats supported by cgit... + */ + ctx.cfg.snapshots = 0xFF; + scan++; + scan_tree(arg, repo_config); + } + } + if (scan) { + qsort(cgit_repolist.repos, cgit_repolist.count, + sizeof(struct cgit_repo), cmp_repos); + print_repolist(stdout, &cgit_repolist, 0); + exit(0); + } +} + +static int calc_ttl(void) +{ + if (!ctx.repo) + return ctx.cfg.cache_root_ttl; + + if (!ctx.qry.page) + return ctx.cfg.cache_repo_ttl; + + if (!strcmp(ctx.qry.page, "about")) + return ctx.cfg.cache_about_ttl; + + if (!strcmp(ctx.qry.page, "snapshot")) + return ctx.cfg.cache_snapshot_ttl; + + if (ctx.qry.has_oid) + return ctx.cfg.cache_static_ttl; + + if (ctx.qry.has_symref) + return ctx.cfg.cache_dynamic_ttl; + + return ctx.cfg.cache_repo_ttl; +} + +int cmd_main(int argc, const char **argv) +{ + const char *path; + int err, ttl; + + atexit(cgit_cleanup_filters); + + prepare_context(); + cgit_repolist.length = 0; + cgit_repolist.count = 0; + cgit_repolist.repos = NULL; + + cgit_parse_args(argc, argv); + parse_configfile(expand_macros(ctx.env.cgit_config), config_cb); + ctx.repo = NULL; + http_parse_querystring(ctx.qry.raw, querystring_cb); + + /* If virtual-root isn't specified in cgitrc, lets pretend + * that virtual-root equals SCRIPT_NAME, minus any possibly + * trailing slashes. + */ + if (!ctx.cfg.virtual_root && ctx.cfg.script_name) + ctx.cfg.virtual_root = ensure_end(ctx.cfg.script_name, '/'); + + /* If no url parameter is specified on the querystring, lets + * use PATH_INFO as url. This allows cgit to work with virtual + * urls without the need for rewriterules in the webserver (as + * long as PATH_INFO is included in the cache lookup key). + */ + path = ctx.env.path_info; + if (!ctx.qry.url && path) { + if (path[0] == '/') + path++; + ctx.qry.url = xstrdup(path); + if (ctx.qry.raw) { + char *newqry = fmtalloc("%s?%s", path, ctx.qry.raw); + free(ctx.qry.raw); + ctx.qry.raw = newqry; + } else + ctx.qry.raw = xstrdup(ctx.qry.url); + cgit_parse_url(ctx.qry.url); + } + + /* Before we go any further, we set ctx.env.authenticated by checking to see + * if the supplied cookie is valid. All cookies are valid if there is no + * auth_filter. If there is an auth_filter, the filter decides. */ + authenticate_cookie(); + + ttl = calc_ttl(); + if (ttl < 0) + ctx.page.expires += 10 * 365 * 24 * 60 * 60; /* 10 years */ + else + ctx.page.expires += ttl * 60; + if (!ctx.env.authenticated || (ctx.env.request_method && !strcmp(ctx.env.request_method, "HEAD"))) + ctx.cfg.cache_size = 0; + err = cache_process(ctx.cfg.cache_size, ctx.cfg.cache_root, + ctx.qry.raw, ttl, process_request); + cgit_cleanup_filters(); + if (err) + cgit_print_error("Error processing page: %s (%d)", + strerror(err), err); + return err; +} diff --git a/third_party/cgit/cgit.css b/third_party/cgit/cgit.css new file mode 100644 index 0000000000..7133a7ba37 --- /dev/null +++ b/third_party/cgit/cgit.css @@ -0,0 +1,889 @@ +div#cgit { + padding: 0em; + margin: 0em; + font-family: sans-serif; + font-size: 10pt; + color: #333; + background: white; + padding: 4px; +} + +div#cgit a { + color: blue; + text-decoration: none; +} + +div#cgit a:hover { + text-decoration: underline; +} + +div#cgit table { + border-collapse: collapse; +} + +div#cgit table#header { + width: 100%; + margin-bottom: 1em; +} + +div#cgit table#header td.logo { + width: 96px; + vertical-align: top; +} + +div#cgit table#header td.main { + font-size: 250%; + padding-left: 10px; + white-space: nowrap; +} + +div#cgit table#header td.main a { + color: #000; +} + +div#cgit table#header td.form { + text-align: right; + vertical-align: bottom; + padding-right: 1em; + padding-bottom: 2px; + white-space: nowrap; +} + +div#cgit table#header td.form form, +div#cgit table#header td.form input, +div#cgit table#header td.form select { + font-size: 90%; +} + +div#cgit table#header td.sub { + color: #777; + border-top: solid 1px #ccc; + padding-left: 10px; +} + +div#cgit table.tabs { + border-bottom: solid 3px #ccc; + border-collapse: collapse; + margin-top: 2em; + margin-bottom: 0px; + width: 100%; +} + +div#cgit table.tabs td { + padding: 0px 1em; + vertical-align: bottom; +} + +div#cgit table.tabs td a { + padding: 2px 0.25em; + color: #777; + font-size: 110%; +} + +div#cgit table.tabs td a.active { + color: #000; + background-color: #ccc; +} + +div#cgit table.tabs a[href^="http://"]:after, div#cgit table.tabs a[href^="https://"]:after { + content: url(data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAoAAAAKCAQAAAAnOwc2AAAAAmJLR0QA/4ePzL8AAAAJcEhZcwAACxMAAAsTAQCanBgAAAAHdElNRQfgAhcJDQY+gm2TAAAAHWlUWHRDb21tZW50AAAAAABDcmVhdGVkIHdpdGggR0lNUGQuZQcAAABbSURBVAhbY2BABs4MU4CwhYHBh2Erww4wrGFQZHjI8B8IgUIscJWyDHcggltQhI4zGDCcRwhChPggHIggP1QoAVmQkSETrGoHsiAEsACtBYN0oDAMbgU6EBcAAL2eHUt4XUU4AAAAAElFTkSuQmCC); + opacity: 0.5; + margin: 0 0 0 5px; +} + +div#cgit table.tabs td.form { + text-align: right; +} + +div#cgit table.tabs td.form form { + padding-bottom: 2px; + font-size: 90%; + white-space: nowrap; +} + +div#cgit table.tabs td.form input, +div#cgit table.tabs td.form select { + font-size: 90%; +} + +div#cgit div.path { + margin: 0px; + padding: 5px 2em 2px 2em; + color: #000; + background-color: #eee; +} + +div#cgit div.content { + margin: 0px; + padding: 2em; + border-bottom: solid 3px #ccc; +} + + +div#cgit table.list { + width: 100%; + border: none; + border-collapse: collapse; +} + +div#cgit table.list tr { + background: white; +} + +div#cgit table.list tr.logheader { + background: #eee; +} + +div#cgit table.list tr:nth-child(even) { + background: #f7f7f7; +} + +div#cgit table.list tr:nth-child(odd) { + background: white; +} + +div#cgit table.list tr:hover { + background: #eee; +} + +div#cgit table.list tr.nohover { + background: white; +} + +div#cgit table.list tr.nohover:hover { + background: white; +} + +div#cgit table.list tr.nohover-highlight:hover:nth-child(even) { + background: #f7f7f7; +} + +div#cgit table.list tr.nohover-highlight:hover:nth-child(odd) { + background: white; +} + +div#cgit table.list th { + font-weight: bold; + /* color: #888; + border-top: dashed 1px #888; + border-bottom: dashed 1px #888; + */ + padding: 0.1em 0.5em 0.05em 0.5em; + vertical-align: baseline; +} + +div#cgit table.list td { + border: none; + padding: 0.1em 0.5em 0.1em 0.5em; +} + +div#cgit table.list td.commitgraph { + font-family: monospace; + white-space: pre; +} + +div#cgit table.list td.commitgraph .column1 { + color: #a00; +} + +div#cgit table.list td.commitgraph .column2 { + color: #0a0; +} + +div#cgit table.list td.commitgraph .column3 { + color: #aa0; +} + +div#cgit table.list td.commitgraph .column4 { + color: #00a; +} + +div#cgit table.list td.commitgraph .column5 { + color: #a0a; +} + +div#cgit table.list td.commitgraph .column6 { + color: #0aa; +} + +div#cgit table.list td.logsubject { + font-family: monospace; + font-weight: bold; +} + +div#cgit table.list td.logmsg { + font-family: monospace; + white-space: pre; + padding: 0 0.5em; +} + +div#cgit table.list td a { + color: black; +} + +div#cgit table.list td a.ls-dir { + font-weight: bold; + color: #00f; +} + +div#cgit table.list td a:hover { + color: #00f; +} + +div#cgit img { + border: none; +} + +div#cgit input#switch-btn { + margin: 2px 0px 0px 0px; +} + +div#cgit td#sidebar input.txt { + width: 100%; + margin: 2px 0px 0px 0px; +} + +div#cgit table#grid { + margin: 0px; +} + +div#cgit td#content { + vertical-align: top; + padding: 1em 2em 1em 1em; + border: none; +} + +div#cgit div#summary { + vertical-align: top; + margin-bottom: 1em; +} + +div#cgit table#downloads { + float: right; + border-collapse: collapse; + border: solid 1px #777; + margin-left: 0.5em; + margin-bottom: 0.5em; +} + +div#cgit table#downloads th { + background-color: #ccc; +} + +div#cgit div#blob { + border: solid 1px black; +} + +div#cgit div.error { + color: red; + font-weight: bold; + margin: 1em 2em; +} + +div#cgit a.ls-blob, div#cgit a.ls-dir, div#cgit .ls-mod { + font-family: monospace; +} + +div#cgit td.ls-size { + text-align: right; + font-family: monospace; + width: 10em; +} + +div#cgit td.ls-mode { + font-family: monospace; + width: 10em; +} + +div#cgit table.blob { + margin-top: 0.5em; + border-top: solid 1px black; +} + +div#cgit table.blob td.hashes, +div#cgit table.blob td.lines { + margin: 0; padding: 0 0 0 0.5em; + vertical-align: top; + color: black; +} + +div#cgit table.blob td.linenumbers { + margin: 0; padding: 0 0.5em 0 0.5em; + vertical-align: top; + text-align: right; + border-right: 1px solid gray; +} + +div#cgit table.blob pre { + padding: 0; margin: 0; +} + +div#cgit table.blob td.linenumbers a, +div#cgit table.ssdiff td.lineno a { + color: gray; + text-align: right; + text-decoration: none; +} + +div#cgit table.blob td.linenumbers a:hover, +div#cgit table.ssdiff td.lineno a:hover { + color: black; +} + +div#cgit table.blame td.hashes, +div#cgit table.blame td.lines, +div#cgit table.blame td.linenumbers { + padding: 0; +} + +div#cgit table.blame td.hashes div.alt, +div#cgit table.blame td.lines div.alt { + padding: 0 0.5em 0 0.5em; +} + +div#cgit table.blame td.linenumbers div.alt { + padding: 0 0.5em 0 0; +} + +div#cgit table.blame div.alt:nth-child(even) { + background: #eee; +} + +div#cgit table.blame div.alt:nth-child(odd) { + background: white; +} + +div#cgit table.blame td.lines > div { + position: relative; +} + +div#cgit table.blame td.lines > div > pre { + padding: 0 0 0 0.5em; + position: absolute; + top: 0; +} + +div#cgit table.blame .oid { + font-size: 100%; +} + +div#cgit table.bin-blob { + margin-top: 0.5em; + border: solid 1px black; +} + +div#cgit table.bin-blob th { + font-family: monospace; + white-space: pre; + border: solid 1px #777; + padding: 0.5em 1em; +} + +div#cgit table.bin-blob td { + font-family: monospace; + white-space: pre; + border-left: solid 1px #777; + padding: 0em 1em; +} + +div#cgit table.nowrap td { + white-space: nowrap; +} + +div#cgit table.commit-info { + border-collapse: collapse; + margin-top: 1.5em; +} + +div#cgit div.cgit-panel { + float: right; + margin-top: 1.5em; +} + +div#cgit div.cgit-panel table { + border-collapse: collapse; + border: solid 1px #aaa; + background-color: #eee; +} + +div#cgit div.cgit-panel th { + text-align: center; +} + +div#cgit div.cgit-panel td { + padding: 0.25em 0.5em; +} + +div#cgit div.cgit-panel td.label { + padding-right: 0.5em; +} + +div#cgit div.cgit-panel td.ctrl { + padding-left: 0.5em; +} + +div#cgit table.commit-info th { + text-align: left; + font-weight: normal; + padding: 0.1em 1em 0.1em 0.1em; + vertical-align: top; +} + +div#cgit table.commit-info td { + font-weight: normal; + padding: 0.1em 1em 0.1em 0.1em; +} + +div#cgit div.commit-subject { + font-weight: bold; + font-size: 125%; + margin: 1.5em 0em 0.5em 0em; + padding: 0em; +} + +div#cgit div.notes-header { + font-weight: bold; + padding-top: 1.5em; +} + +div#cgit div.notes { + white-space: pre; + font-family: monospace; + border: solid 1px #ee9; + background-color: #ffd; + padding: 0.3em 2em 0.3em 1em; + float: left; +} + +div#cgit div.notes-footer { + clear: left; +} + +div#cgit div.diffstat-header { + font-weight: bold; + padding-top: 1.5em; +} + +div#cgit table.diffstat { + border-collapse: collapse; + border: solid 1px #aaa; + background-color: #eee; +} + +div#cgit table.diffstat th { + font-weight: normal; + text-align: left; + text-decoration: underline; + padding: 0.1em 1em 0.1em 0.1em; + font-size: 100%; +} + +div#cgit table.diffstat td { + padding: 0.2em 0.2em 0.1em 0.1em; + font-size: 100%; + border: none; +} + +div#cgit table.diffstat td.mode { + white-space: nowrap; +} + +div#cgit table.diffstat td span.modechange { + padding-left: 1em; + color: red; +} + +div#cgit table.diffstat td.add a { + color: green; +} + +div#cgit table.diffstat td.del a { + color: red; +} + +div#cgit table.diffstat td.upd a { + color: blue; +} + +div#cgit table.diffstat td.graph { + width: 500px; + vertical-align: middle; +} + +div#cgit table.diffstat td.graph table { + border: none; +} + +div#cgit table.diffstat td.graph td { + padding: 0px; + border: 0px; + height: 7pt; +} + +div#cgit table.diffstat td.graph td.add { + background-color: #5c5; +} + +div#cgit table.diffstat td.graph td.rem { + background-color: #c55; +} + +div#cgit div.diffstat-summary { + color: #888; + padding-top: 0.5em; +} + +div#cgit table.diff { + width: 100%; +} + +div#cgit table.diff td span.head { + font-weight: bold; + color: black; +} + +div#cgit table.diff td span.hunk { + color: #009; +} + +div#cgit table.diff td span.add { + color: green; +} + +div#cgit table.diff td span.del { + color: red; +} + +div#cgit .oid { + font-family: monospace; + font-size: 90%; +} + +div#cgit .left { + text-align: left; +} + +div#cgit .right { + text-align: right; +} + +div#cgit table.list td.reposection { + font-style: italic; + color: #888; +} + +div#cgit a.button { + font-size: 80%; +} + +div#cgit a.primary { + font-size: 100%; +} + +div#cgit a.secondary { + font-size: 90%; +} + +div#cgit td.toplevel-repo { + +} + +div#cgit table.list td.sublevel-repo { + padding-left: 1.5em; +} + +div#cgit ul.pager { + list-style-type: none; + text-align: center; + margin: 1em 0em 0em 0em; + padding: 0; +} + +div#cgit ul.pager li { + display: inline-block; + margin: 0.25em 0.5em; +} + +div#cgit ul.pager a { + color: #777; +} + +div#cgit ul.pager .current { + font-weight: bold; +} + +div#cgit span.age-mins { + font-weight: bold; + color: #080; +} + +div#cgit span.age-hours { + color: #080; +} + +div#cgit span.age-days { + color: #040; +} + +div#cgit span.age-weeks { + color: #444; +} + +div#cgit span.age-months { + color: #888; +} + +div#cgit span.age-years { + color: #bbb; +} + +div#cgit span.insertions { + color: #080; +} + +div#cgit span.deletions { + color: #800; +} + +div#cgit div.footer { + margin-top: 0.5em; + text-align: center; + font-size: 80%; + color: #ccc; +} + +div#cgit div.footer a { + color: #ccc; + text-decoration: none; +} + +div#cgit div.footer a:hover { + text-decoration: underline; +} + +div#cgit a.branch-deco { + color: #000; + padding: 0px 0.25em; + background-color: #88ff88; + border: solid 1px #007700; +} + +div#cgit a.rev-deco { + color: #000; + padding: 0px 0.25em; + background-color: #eee; + border: solid 1px #aaa; +} + +div#cgit a.tag-deco { + color: #000; + padding: 0px 0.25em; + background-color: #ffff88; + border: solid 1px #777700; +} + +div#cgit a.tag-annotated-deco { + color: #000; + padding: 0px 0.25em; + background-color: #ffcc88; + border: solid 1px #777700; +} + +div#cgit a.remote-deco { + color: #000; + padding: 0px 0.25em; + background-color: #ccccff; + border: solid 1px #000077; +} + +div#cgit a.deco { + color: #000; + padding: 0px 0.25em; + background-color: #ff8888; + border: solid 1px #770000; +} + +div#cgit div.commit-subject a.branch-deco, +div#cgit div.commit-subject a.tag-deco, +div#cgit div.commit-subject a.tag-annotated-deco, +div#cgit div.commit-subject a.remote-deco, +div#cgit div.commit-subject a.rev-deco, +div#cgit div.commit-subject a.deco { + font-size: 75%; +} + +div#cgit table.stats { + border: solid 1px black; + border-collapse: collapse; +} + +div#cgit table.stats th { + text-align: left; + padding: 1px 0.5em; + background-color: #eee; + border: solid 1px black; +} + +div#cgit table.stats td { + text-align: right; + padding: 1px 0.5em; + border: solid 1px black; +} + +div#cgit table.stats td.total { + font-weight: bold; + text-align: left; +} + +div#cgit table.stats td.sum { + color: #c00; + font-weight: bold; +/* background-color: #eee; */ +} + +div#cgit table.stats td.left { + text-align: left; +} + +div#cgit table.vgraph { + border-collapse: separate; + border: solid 1px black; + height: 200px; +} + +div#cgit table.vgraph th { + background-color: #eee; + font-weight: bold; + border: solid 1px white; + padding: 1px 0.5em; +} + +div#cgit table.vgraph td { + vertical-align: bottom; + padding: 0px 10px; +} + +div#cgit table.vgraph div.bar { + background-color: #eee; +} + +div#cgit table.hgraph { + border: solid 1px black; + width: 800px; +} + +div#cgit table.hgraph th { + background-color: #eee; + font-weight: bold; + border: solid 1px black; + padding: 1px 0.5em; +} + +div#cgit table.hgraph td { + vertical-align: middle; + padding: 2px 2px; +} + +div#cgit table.hgraph div.bar { + background-color: #eee; + height: 1em; +} + +div#cgit table.ssdiff { + width: 100%; +} + +div#cgit table.ssdiff td { + font-size: 75%; + font-family: monospace; + white-space: pre; + padding: 1px 4px 1px 4px; + border-left: solid 1px #aaa; + border-right: solid 1px #aaa; +} + +div#cgit table.ssdiff td.add { + color: black; + background: #cfc; + min-width: 50%; +} + +div#cgit table.ssdiff td.add_dark { + color: black; + background: #aca; + min-width: 50%; +} + +div#cgit table.ssdiff span.add { + background: #cfc; + font-weight: bold; +} + +div#cgit table.ssdiff td.del { + color: black; + background: #fcc; + min-width: 50%; +} + +div#cgit table.ssdiff td.del_dark { + color: black; + background: #caa; + min-width: 50%; +} + +div#cgit table.ssdiff span.del { + background: #fcc; + font-weight: bold; +} + +div#cgit table.ssdiff td.changed { + color: black; + background: #ffc; + min-width: 50%; +} + +div#cgit table.ssdiff td.changed_dark { + color: black; + background: #cca; + min-width: 50%; +} + +div#cgit table.ssdiff td.lineno { + color: black; + background: #eee; + text-align: right; + width: 3em; + min-width: 3em; +} + +div#cgit table.ssdiff td.hunk { + color: black; + background: #ccf; + border-top: solid 1px #aaa; + border-bottom: solid 1px #aaa; +} + +div#cgit table.ssdiff td.head { + border-top: solid 1px #aaa; + border-bottom: solid 1px #aaa; +} + +div#cgit table.ssdiff td.head div.head { + font-weight: bold; + color: black; +} + +div#cgit table.ssdiff td.foot { + border-top: solid 1px #aaa; + border-left: none; + border-right: none; + border-bottom: none; +} + +div#cgit table.ssdiff td.space { + border: none; +} + +div#cgit table.ssdiff td.space div { + min-height: 3em; +} diff --git a/third_party/cgit/cgit.h b/third_party/cgit/cgit.h new file mode 100644 index 0000000000..f201f82b85 --- /dev/null +++ b/third_party/cgit/cgit.h @@ -0,0 +1,405 @@ +#ifndef CGIT_H +#define CGIT_H + +#include <stdbool.h> + +#include <git-compat-util.h> + +#include <archive.h> +#include <commit.h> +#include <diffcore.h> +#include <diff.h> +#include <environment.h> +#include <graph.h> +#include <grep.h> +#include <hex.h> +#include <log-tree.h> +#include <notes.h> +#include <object.h> +#include <object-name.h> +#include <object-store.h> +#include <path.h> +#include <refs.h> +#include <revision.h> +#include <setup.h> +#include <string-list.h> +#include <strvec.h> +#include <tag.h> +#include <tree.h> +#include <utf8.h> +#include <wrapper.h> +#include <xdiff-interface.h> +#include <xdiff/xdiff.h> +#include <utf8.h> +#include <notes.h> +#include <graph.h> + +/* Add isgraph(x) to Git's sane ctype support (see git-compat-util.h) */ +#undef isgraph +#define isgraph(x) (isprint((x)) && !isspace((x))) + + +/* + * Limits used for relative dates + */ +#define TM_MIN 60 +#define TM_HOUR (TM_MIN * 60) +#define TM_DAY (TM_HOUR * 24) +#define TM_WEEK (TM_DAY * 7) +#define TM_YEAR (TM_DAY * 365) +#define TM_MONTH (TM_YEAR / 12.0) + + +/* + * Default encoding + */ +#define PAGE_ENCODING "UTF-8" + +#define BIT(x) (1U << (x)) + +typedef void (*configfn)(const char *name, const char *value); +typedef void (*filepair_fn)(struct diff_filepair *pair); +typedef void (*linediff_fn)(char *line, int len); + +typedef enum { + DIFF_UNIFIED, DIFF_SSDIFF, DIFF_STATONLY +} diff_type; + +typedef enum { + ABOUT, COMMIT, SOURCE, EMAIL, AUTH, OWNER +} filter_type; + +struct cgit_filter { + int (*open)(struct cgit_filter *, va_list ap); + int (*close)(struct cgit_filter *); + void (*fprintf)(struct cgit_filter *, FILE *, const char *prefix); + void (*cleanup)(struct cgit_filter *); + int argument_count; +}; + +struct cgit_exec_filter { + struct cgit_filter base; + char *cmd; + char **argv; + int old_stdout; + int pid; +}; + +struct cgit_repo { + char *url; + char *name; + char *path; + char *desc; + char *extra_head_content; + char *owner; + char *homepage; + char *defbranch; + char *module_link; + struct string_list readme; + char *section; + char *clone_url; + char *logo; + char *logo_link; + char *snapshot_prefix; + int snapshots; + int enable_blame; + int enable_commit_graph; + int enable_log_filecount; + int enable_log_linecount; + int enable_remote_branches; + int enable_subject_links; + int enable_html_serving; + int max_stats; + int branch_sort; + int commit_sort; + time_t mtime; + struct cgit_filter *about_filter; + struct cgit_filter *commit_filter; + struct cgit_filter *source_filter; + struct cgit_filter *email_filter; + struct cgit_filter *owner_filter; + struct string_list submodules; + int hide; + int ignore; +}; + +typedef void (*repo_config_fn)(struct cgit_repo *repo, const char *name, + const char *value); + +struct cgit_repolist { + int length; + int count; + struct cgit_repo *repos; +}; + +struct commitinfo { + struct commit *commit; + char *author; + char *author_email; + unsigned long author_date; + int author_tz; + char *committer; + char *committer_email; + unsigned long committer_date; + int committer_tz; + char *subject; + char *msg; + char *msg_encoding; +}; + +struct taginfo { + char *tagger; + char *tagger_email; + unsigned long tagger_date; + int tagger_tz; + char *msg; +}; + +struct refinfo { + const char *refname; + struct object *object; + union { + struct taginfo *tag; + struct commitinfo *commit; + }; +}; + +struct reflist { + struct refinfo **refs; + int alloc; + int count; +}; + +struct cgit_query { + int has_symref; + int has_oid; + int has_difftype; + char *raw; + char *repo; + char *page; + char *search; + char *grep; + char *head; + char *oid; + char *oid2; + char *path; + char *name; + char *url; + char *period; + int ofs; + int nohead; + char *sort; + int showmsg; + diff_type difftype; + int show_all; + int context; + int ignorews; + int follow; + char *vpath; +}; + +struct cgit_config { + char *agefile; + char *cache_root; + char *clone_prefix; + char *clone_url; + char *css; + char *favicon; + char *footer; + char *head_include; + char *header; + char *logo; + char *logo_link; + char *mimetype_file; + char *module_link; + char *project_list; + struct string_list readme; + char *robots; + char *root_title; + char *root_desc; + char *root_readme; + char *script_name; + char *section; + char *repository_sort; + char *virtual_root; /* Always ends with '/'. */ + char *strict_export; + int cache_size; + int cache_dynamic_ttl; + int cache_max_create_time; + int cache_repo_ttl; + int cache_root_ttl; + int cache_scanrc_ttl; + int cache_static_ttl; + int cache_about_ttl; + int cache_snapshot_ttl; + int case_sensitive_sort; + int embedded; + int enable_filter_overrides; + int enable_follow_links; + int enable_http_clone; + int enable_index_links; + int enable_index_owner; + int enable_blame; + int enable_commit_graph; + int enable_log_filecount; + int enable_log_linecount; + int enable_remote_branches; + int enable_subject_links; + int enable_html_serving; + int enable_tree_linenumbers; + int enable_git_config; + int local_time; + int max_atom_items; + int max_repo_count; + int max_commit_count; + int max_lock_attempts; + int max_msg_len; + int max_repodesc_len; + int max_blob_size; + int max_stats; + int noplainemail; + int noheader; + int renamelimit; + int remove_suffix; + int scan_hidden_path; + int section_from_path; + int snapshots; + int section_sort; + int summary_branches; + int summary_log; + int summary_tags; + diff_type difftype; + int branch_sort; + int commit_sort; + struct string_list mimetypes; + struct cgit_filter *about_filter; + struct cgit_filter *commit_filter; + struct cgit_filter *source_filter; + struct cgit_filter *email_filter; + struct cgit_filter *owner_filter; + struct cgit_filter *auth_filter; +}; + +struct cgit_page { + time_t modified; + time_t expires; + size_t size; + const char *mimetype; + const char *charset; + const char *filename; + const char *etag; + const char *title; + int status; + const char *statusmsg; +}; + +struct cgit_environment { + const char *cgit_config; + const char *http_host; + const char *https; + const char *no_http; + const char *path_info; + const char *query_string; + const char *request_method; + const char *script_name; + const char *server_name; + const char *server_port; + const char *http_cookie; + const char *http_referer; + unsigned int content_length; + int authenticated; +}; + +struct cgit_context { + struct cgit_environment env; + struct cgit_query qry; + struct cgit_config cfg; + struct cgit_repo *repo; + struct cgit_page page; +}; + +typedef int (*write_archive_fn_t)(const char *, const char *); + +struct cgit_snapshot_format { + const char *suffix; + const char *mimetype; + write_archive_fn_t write_func; +}; + +extern const char *cgit_version; + +extern struct cgit_repolist cgit_repolist; +extern struct cgit_context ctx; +extern const struct cgit_snapshot_format cgit_snapshot_formats[]; + +extern char *cgit_default_repo_desc; +extern struct cgit_repo *cgit_add_repo(const char *url); +extern struct cgit_repo *cgit_get_repoinfo(const char *url); +extern void cgit_repo_config_cb(const char *name, const char *value); + +extern int chk_zero(int result, char *msg); +extern int chk_positive(int result, char *msg); +extern int chk_non_negative(int result, char *msg); + +extern char *trim_end(const char *str, char c); +extern char *ensure_end(const char *str, char c); + +extern void strbuf_ensure_end(struct strbuf *sb, char c); + +extern void cgit_add_ref(struct reflist *list, struct refinfo *ref); +extern void cgit_free_reflist_inner(struct reflist *list); +extern int cgit_refs_cb(const char *refname, const struct object_id *oid, + int flags, void *cb_data); + +extern void cgit_free_commitinfo(struct commitinfo *info); +extern void cgit_free_taginfo(struct taginfo *info); + +void cgit_diff_tree_cb(struct diff_queue_struct *q, + struct diff_options *options, void *data); + +extern int cgit_diff_files(const struct object_id *old_oid, + const struct object_id *new_oid, + unsigned long *old_size, unsigned long *new_size, + int *binary, int context, int ignorews, + linediff_fn fn); + +extern void cgit_diff_tree(const struct object_id *old_oid, + const struct object_id *new_oid, + filepair_fn fn, const char *prefix, int ignorews); + +extern void cgit_diff_commit(struct commit *commit, filepair_fn fn, + const char *prefix); + +__attribute__((format (printf,1,2))) +extern char *fmt(const char *format,...); + +__attribute__((format (printf,1,2))) +extern char *fmtalloc(const char *format,...); + +extern struct commitinfo *cgit_parse_commit(struct commit *commit); +extern struct taginfo *cgit_parse_tag(struct tag *tag); +extern void cgit_parse_url(const char *url); + +extern const char *cgit_repobasename(const char *reponame); + +extern int cgit_parse_snapshots_mask(const char *str); +extern const struct object_id *cgit_snapshot_get_sig(const char *ref, + const struct cgit_snapshot_format *f); +extern const unsigned cgit_snapshot_format_bit(const struct cgit_snapshot_format *f); + +extern int cgit_open_filter(struct cgit_filter *filter, ...); +extern int cgit_close_filter(struct cgit_filter *filter); +extern void cgit_fprintf_filter(struct cgit_filter *filter, FILE *f, const char *prefix); +extern void cgit_exec_filter_init(struct cgit_exec_filter *filter, char *cmd, char **argv); +extern struct cgit_filter *cgit_new_filter(const char *cmd, filter_type filtertype); +extern void cgit_cleanup_filters(void); + +extern void cgit_prepare_repo_env(struct cgit_repo * repo); + +extern int readfile(const char *path, char **buf, size_t *size); + +extern char *expand_macros(const char *txt); + +extern char *get_mimetype_for_filename(const char *filename); + +#endif /* CGIT_H */ diff --git a/third_party/cgit/cgit.mk b/third_party/cgit/cgit.mk new file mode 100644 index 0000000000..5b9ed5be8e --- /dev/null +++ b/third_party/cgit/cgit.mk @@ -0,0 +1,114 @@ +# This Makefile is run in the "git" directory in order to re-use Git's +# build variables and operating system detection. Hence all files in +# CGit's directory must be prefixed with "../". +include Makefile + +CGIT_PREFIX = ../ + +-include $(CGIT_PREFIX)cgit.conf + +# The CGIT_* variables are inherited when this file is called from the +# main Makefile - they are defined there. + +$(CGIT_PREFIX)VERSION: force-version + @cd $(CGIT_PREFIX) && '$(SHELL_PATH_SQ)' ./gen-version.sh "$(CGIT_VERSION)" +-include $(CGIT_PREFIX)VERSION +.PHONY: force-version + +# CGIT_CFLAGS is a separate variable so that we can track it separately +# and avoid rebuilding all of Git when these variables change. +CGIT_CFLAGS += -DCGIT_CONFIG='"$(CGIT_CONFIG)"' +CGIT_CFLAGS += -DCGIT_SCRIPT_NAME='"$(CGIT_SCRIPT_NAME)"' +CGIT_CFLAGS += -DCGIT_CACHE_ROOT='"$(CACHE_ROOT)"' + +PKG_CONFIG ?= pkg-config + +ifdef NO_C99_FORMAT + CFLAGS += -DNO_C99_FORMAT +endif + +# Add -ldl to linker flags on systems that commonly use GNU libc. +ifneq (,$(filter $(uname_S),Linux GNU GNU/kFreeBSD)) + CGIT_LIBS += -ldl +endif + +# glibc 2.1+ offers sendfile which the most common C library on Linux +ifeq ($(uname_S),Linux) + HAVE_LINUX_SENDFILE = YesPlease +endif + +ifdef HAVE_LINUX_SENDFILE + CGIT_CFLAGS += -DHAVE_LINUX_SENDFILE +endif + +CGIT_OBJ_NAMES += cgit.o +CGIT_OBJ_NAMES += cache.o +CGIT_OBJ_NAMES += cmd.o +CGIT_OBJ_NAMES += configfile.o +CGIT_OBJ_NAMES += filter.o +CGIT_OBJ_NAMES += html.o +CGIT_OBJ_NAMES += parsing.o +CGIT_OBJ_NAMES += scan-tree.o +CGIT_OBJ_NAMES += shared.o +CGIT_OBJ_NAMES += ui-atom.o +CGIT_OBJ_NAMES += ui-blame.o +CGIT_OBJ_NAMES += ui-blob.o +CGIT_OBJ_NAMES += ui-clone.o +CGIT_OBJ_NAMES += ui-commit.o +CGIT_OBJ_NAMES += ui-diff.o +CGIT_OBJ_NAMES += ui-log.o +CGIT_OBJ_NAMES += ui-patch.o +CGIT_OBJ_NAMES += ui-plain.o +CGIT_OBJ_NAMES += ui-refs.o +CGIT_OBJ_NAMES += ui-repolist.o +CGIT_OBJ_NAMES += ui-shared.o +CGIT_OBJ_NAMES += ui-snapshot.o +CGIT_OBJ_NAMES += ui-ssdiff.o +CGIT_OBJ_NAMES += ui-stats.o +CGIT_OBJ_NAMES += ui-summary.o +CGIT_OBJ_NAMES += ui-tag.o +CGIT_OBJ_NAMES += ui-tree.o + +CGIT_OBJS := $(addprefix $(CGIT_PREFIX),$(CGIT_OBJ_NAMES)) + +# Only cgit.c reference CGIT_VERSION so we only rebuild its objects when the +# version changes. +CGIT_VERSION_OBJS := $(addprefix $(CGIT_PREFIX),cgit.o cgit.sp) +$(CGIT_VERSION_OBJS): $(CGIT_PREFIX)VERSION +$(CGIT_VERSION_OBJS): EXTRA_CPPFLAGS = \ + -DCGIT_VERSION='"$(CGIT_VERSION)"' + +# Git handles dependencies using ":=" so dependencies in CGIT_OBJ are not +# handled by that and we must handle them ourselves. +cgit_dep_files := $(foreach f,$(CGIT_OBJS),$(dir $f).depend/$(notdir $f).d) +cgit_dep_files_present := $(wildcard $(cgit_dep_files)) +ifneq ($(cgit_dep_files_present),) +include $(cgit_dep_files_present) +endif + +ifeq ($(wildcard $(CGIT_PREFIX).depend),) +missing_dep_dirs += $(CGIT_PREFIX).depend +endif + +$(CGIT_PREFIX).depend: + @mkdir -p $@ + +$(CGIT_PREFIX)CGIT-CFLAGS: FORCE + @FLAGS='$(subst ','\'',$(CGIT_CFLAGS))'; \ + if test x"$$FLAGS" != x"`cat ../CGIT-CFLAGS 2>/dev/null`" ; then \ + echo 1>&2 " * new CGit build flags"; \ + echo "$$FLAGS" >$(CGIT_PREFIX)CGIT-CFLAGS; \ + fi + +$(CGIT_OBJS): %.o: %.c GIT-CFLAGS $(CGIT_PREFIX)CGIT-CFLAGS $(missing_dep_dirs) + $(QUIET_CC)$(CC) -o $*.o -c $(dep_args) $(ALL_CFLAGS) $(EXTRA_CPPFLAGS) $(CGIT_CFLAGS) $< + +$(CGIT_PREFIX)cgit: $(CGIT_OBJS) GIT-LDFLAGS $(GITLIBS) + $(QUIET_LINK)$(CC) $(ALL_CFLAGS) -o $@ $(ALL_LDFLAGS) $(filter %.o,$^) $(LIBS) $(CGIT_LIBS) + +CGIT_SP_OBJS := $(patsubst %.o,%.sp,$(CGIT_OBJS)) + +$(CGIT_SP_OBJS): %.sp: %.c GIT-CFLAGS $(CGIT_PREFIX)CGIT-CFLAGS FORCE + $(QUIET_SP)cgcc -no-compile $(ALL_CFLAGS) $(EXTRA_CPPFLAGS) $(CGIT_CFLAGS) $(SPARSE_FLAGS) $< + +cgit-sparse: $(CGIT_SP_OBJS) diff --git a/third_party/cgit/cgit.png b/third_party/cgit/cgit.png new file mode 100644 index 0000000000..425528ee39 --- /dev/null +++ b/third_party/cgit/cgit.png Binary files differdiff --git a/third_party/cgit/cgitrc.5.txt b/third_party/cgit/cgitrc.5.txt new file mode 100644 index 0000000000..cafb5355ea --- /dev/null +++ b/third_party/cgit/cgitrc.5.txt @@ -0,0 +1,977 @@ +:man source: cgit +:man manual: cgit + +CGITRC(5) +======== + + +NAME +---- +cgitrc - runtime configuration for cgit + + +SYNOPSIS +-------- +Cgitrc contains all runtime settings for cgit, including the list of git +repositories, formatted as a line-separated list of NAME=VALUE pairs. Blank +lines, and lines starting with '#', are ignored. + + +LOCATION +-------- +The default location of cgitrc, defined at compile time, is /etc/cgitrc. At +runtime, cgit will consult the environment variable CGIT_CONFIG and, if +defined, use its value instead. + + +GLOBAL SETTINGS +--------------- +about-filter:: + Specifies a command which will be invoked to format the content of + about pages (both top-level and for each repository). The command will + get the content of the about-file on its STDIN, the name of the file + as the first argument, and the STDOUT from the command will be + included verbatim on the about page. Default value: none. See + also: "FILTER API". + +agefile:: + Specifies a path, relative to each repository path, which can be used + to specify the date and time of the youngest commit in the repository. + The first line in the file is used as input to the "parse_date" + function in libgit. Recommended timestamp-format is "yyyy-mm-dd + hh:mm:ss". You may want to generate this file from a post-receive + hook. Default value: "info/web/last-modified". + +auth-filter:: + Specifies a command that will be invoked for authenticating repository + access. Receives quite a few arguments, and data on both stdin and + stdout for authentication processing. Details follow later in this + document. If no auth-filter is specified, no authentication is + performed. Default value: none. See also: "FILTER API". + +branch-sort:: + Flag which, when set to "age", enables date ordering in the branch ref + list, and when set to "name" enables ordering by branch name. Default + value: "name". + +cache-about-ttl:: + Number which specifies the time-to-live, in minutes, for the cached + version of the repository about page. See also: "CACHE". Default + value: "15". + +cache-dynamic-ttl:: + Number which specifies the time-to-live, in minutes, for the cached + version of repository pages accessed without a fixed SHA1. See also: + "CACHE". Default value: "5". + +cache-repo-ttl:: + Number which specifies the time-to-live, in minutes, for the cached + version of the repository summary page. See also: "CACHE". Default + value: "5". + +cache-root:: + Path used to store the cgit cache entries. Default value: + "/var/cache/cgit". See also: "MACRO EXPANSION". + +cache-root-ttl:: + Number which specifies the time-to-live, in minutes, for the cached + version of the repository index page. See also: "CACHE". Default + value: "5". + +cache-scanrc-ttl:: + Number which specifies the time-to-live, in minutes, for the result + of scanning a path for git repositories. See also: "CACHE". Default + value: "15". + +case-sensitive-sort:: + Sort items in the repo list case sensitively. Default value: "1". + See also: repository-sort, section-sort. + +cache-size:: + The maximum number of entries in the cgit cache. When set to "0", + caching is disabled. See also: "CACHE". Default value: "0" + +cache-snapshot-ttl:: + Number which specifies the time-to-live, in minutes, for the cached + version of snapshots. See also: "CACHE". Default value: "5". + +cache-static-ttl:: + Number which specifies the time-to-live, in minutes, for the cached + version of repository pages accessed with a fixed SHA1. See also: + "CACHE". Default value: -1". + +clone-prefix:: + Space-separated list of common prefixes which, when combined with a + repository url, generates valid clone urls for the repository. This + setting is only used if `repo.clone-url` is unspecified. Default value: + none. + +clone-url:: + Space-separated list of clone-url templates. This setting is only + used if `repo.clone-url` is unspecified. Default value: none. See + also: "MACRO EXPANSION", "FILTER API". + +commit-filter:: + Specifies a command which will be invoked to format commit messages. + The command will get the message on its STDIN, and the STDOUT from the + command will be included verbatim as the commit message, i.e. this can + be used to implement bugtracker integration. Default value: none. + See also: "FILTER API". + +commit-sort:: + Flag which, when set to "date", enables strict date ordering in the + commit log, and when set to "topo" enables strict topological + ordering. If unset, the default ordering of "git log" is used. Default + value: unset. + +css:: + Url which specifies the css document to include in all cgit pages. + Default value: "/cgit.css". + +email-filter:: + Specifies a command which will be invoked to format names and email + address of committers, authors, and taggers, as represented in various + places throughout the cgit interface. This command will receive an + email address and an origin page string as its command line arguments, + and the text to format on STDIN. It is to write the formatted text back + out onto STDOUT. Default value: none. See also: "FILTER API". + +embedded:: + Flag which, when set to "1", will make cgit generate a html fragment + suitable for embedding in other html pages. Default value: none. See + also: "noheader". + +enable-blame:: + Flag which, when set to "1", will allow cgit to provide a "blame" page + for files, and will make it generate links to that page in appropriate + places. Default value: "0". + +enable-commit-graph:: + Flag which, when set to "1", will make cgit print an ASCII-art commit + history graph to the left of the commit messages in the repository + log page. Default value: "0". + +enable-filter-overrides:: + Flag which, when set to "1", allows all filter settings to be + overridden in repository-specific cgitrc files. Default value: none. + +enable-follow-links:: + Flag which, when set to "1", allows users to follow a file in the log + view. Default value: "0". + +enable-git-config:: + Flag which, when set to "1", will allow cgit to use git config to set + any repo specific settings. This option is used in conjunction with + "scan-path", and must be defined prior, to augment repo-specific + settings. The keys gitweb.owner, gitweb.category, gitweb.description, + and gitweb.homepage will map to the cgit keys repo.owner, repo.section, + repo.desc, and repo.homepage respectively. All git config keys that begin + with "cgit." will be mapped to the corresponding "repo." key in cgit. + Default value: "0". See also: scan-path, section-from-path. + +enable-http-clone:: + If set to "1", cgit will act as a dumb HTTP endpoint for git clones. + You can add "http://$HTTP_HOST$SCRIPT_NAME/$CGIT_REPO_URL" to clone-url + to expose this feature. If you use an alternate way of serving git + repositories, you may wish to disable this. Default value: "1". + +enable-html-serving:: + Flag which, when set to "1", will allow the /plain handler to serve + mimetype headers that result in the file being treated as HTML by the + browser. When set to "0", such file types are returned instead as + text/plain or application/octet-stream. Default value: "0". See also: + "repo.enable-html-serving". + +enable-index-links:: + Flag which, when set to "1", will make cgit generate extra links for + each repo in the repository index (specifically, to the "summary", + "commit" and "tree" pages). Default value: "0". + +enable-index-owner:: + Flag which, when set to "1", will make cgit display the owner of + each repo in the repository index. Default value: "1". + +enable-log-filecount:: + Flag which, when set to "1", will make cgit print the number of + modified files for each commit on the repository log page. Default + value: "0". + +enable-log-linecount:: + Flag which, when set to "1", will make cgit print the number of added + and removed lines for each commit on the repository log page. Default + value: "0". + +enable-remote-branches:: + Flag which, when set to "1", will make cgit display remote branches + in the summary and refs views. Default value: "0". See also: + "repo.enable-remote-branches". + +enable-subject-links:: + Flag which, when set to "1", will make cgit use the subject of the + parent commit as link text when generating links to parent commits + in commit view. Default value: "0". See also: + "repo.enable-subject-links". + +enable-tree-linenumbers:: + Flag which, when set to "1", will make cgit generate linenumber links + for plaintext blobs printed in the tree view. Default value: "1". + +favicon:: + Url used as link to a shortcut icon for cgit. It is suggested to use + the value "/favicon.ico" since certain browsers will ignore other + values. Default value: none. + +footer:: + The content of the file specified with this option will be included + verbatim at the bottom of all pages (i.e. it replaces the standard + "generated by..." message. Default value: none. + +head-include:: + The content of the file specified with this option will be included + verbatim in the html HEAD section on all pages. Default value: none. + +header:: + The content of the file specified with this option will be included + verbatim at the top of all pages. Default value: none. + +include:: + Name of a configfile to include before the rest of the current config- + file is parsed. Default value: none. See also: "MACRO EXPANSION". + +local-time:: + Flag which, if set to "1", makes cgit print commit and tag times in the + servers timezone. Default value: "0". + +logo:: + Url which specifies the source of an image which will be used as a logo + on all cgit pages. Default value: "/cgit.png". + +logo-link:: + Url loaded when clicking on the cgit logo image. If unspecified the + calculated url of the repository index page will be used. Default + value: none. + +max-atom-items:: + Specifies the number of items to display in atom feeds view. Default + value: "10". + +max-blob-size:: + Specifies the maximum size of a blob to display HTML for in KBytes. + Default value: "0" (limit disabled). + +max-commit-count:: + Specifies the number of entries to list per page in "log" view. Default + value: "50". + +max-message-length:: + Specifies the maximum number of commit message characters to display in + "log" view. Default value: "80". + +max-repo-count:: + Specifies the number of entries to list per page on the repository + index page. Default value: "50". + +max-repodesc-length:: + Specifies the maximum number of repo description characters to display + on the repository index page. Default value: "80". + +max-stats:: + Set the default maximum statistics period. Valid values are "week", + "month", "quarter" and "year". If unspecified, statistics are + disabled. Default value: none. See also: "repo.max-stats". + +mimetype.<ext>:: + Set the mimetype for the specified filename extension. This is used + by the `plain` command when returning blob content. + +mimetype-file:: + Specifies the file to use for automatic mimetype lookup. If specified + then this field is used as a fallback when no "mimetype.<ext>" match is + found. If unspecified then no such lookup is performed. The typical file + to use on a Linux system is /etc/mime.types. The format of the file must + comply to: + - a comment line is an empty line or a line starting with a hash (#), + optionally preceded by whitespace + - a non-comment line starts with the mimetype (like image/png), followed + by one or more file extensions (like jpg), all separated by whitespace + Default value: none. See also: "mimetype.<ext>". + +module-link:: + Text which will be used as the formatstring for a hyperlink when a + submodule is printed in a directory listing. The arguments for the + formatstring are the path and SHA1 of the submodule commit. Default + value: none. + +noplainemail:: + If set to "1" showing full author email addresses will be disabled. + Default value: "0". + +noheader:: + Flag which, when set to "1", will make cgit omit the standard header + on all pages. Default value: none. See also: "embedded". + +owner-filter:: + Specifies a command which will be invoked to format the Owner + column of the main page. The command will get the owner on STDIN, + and the STDOUT from the command will be included verbatim in the + table. This can be used to link to additional context such as an + owners home page. When active this filter is used instead of the + default owner query url. Default value: none. + See also: "FILTER API". + +project-list:: + A list of subdirectories inside of scan-path, relative to it, that + should loaded as git repositories. This must be defined prior to + scan-path. Default value: none. See also: scan-path, "MACRO + EXPANSION". + +readme:: + Text which will be used as default value for "repo.readme". Multiple + config keys may be specified, and cgit will use the first found file + in this list. This is useful in conjunction with scan-path. Default + value: none. See also: scan-path, repo.readme. + +remove-suffix:: + If set to "1" and scan-path is enabled, if any repositories are found + with a suffix of ".git", this suffix will be removed for the url and + name. This must be defined prior to scan-path. Default value: "0". + See also: scan-path. + +renamelimit:: + Maximum number of files to consider when detecting renames. The value + "-1" uses the compiletime value in git (for further info, look at + `man git-diff`). Default value: "-1". + +repository-sort:: + The way in which repositories in each section are sorted. Valid values + are "name" for sorting by the repo name or "age" for sorting by the + most recently updated repository. Default value: "name". See also: + section, case-sensitive-sort, section-sort. + +robots:: + Text used as content for the "robots" meta-tag. Default value: + "index, nofollow". + +root-desc:: + Text printed below the heading on the repository index page. Default + value: "a fast webinterface for the git dscm". + +root-readme:: + The content of the file specified with this option will be included + verbatim below the "about" link on the repository index page. Default + value: none. + +root-title:: + Text printed as heading on the repository index page. Default value: + "Git Repository Browser". + +scan-hidden-path:: + If set to "1" and scan-path is enabled, scan-path will recurse into + directories whose name starts with a period ('.'). Otherwise, + scan-path will stay away from such directories (considered as + "hidden"). Note that this does not apply to the ".git" directory in + non-bare repos. This must be defined prior to scan-path. + Default value: 0. See also: scan-path. + +scan-path:: + A path which will be scanned for repositories. If caching is enabled, + the result will be cached as a cgitrc include-file in the cache + directory. If project-list has been defined prior to scan-path, + scan-path loads only the directories listed in the file pointed to by + project-list. Be advised that only the global settings taken + before the scan-path directive will be applied to each repository. + Default value: none. See also: cache-scanrc-ttl, project-list, + "MACRO EXPANSION". + +section:: + The name of the current repository section - all repositories defined + after this option will inherit the current section name. Default value: + none. + +section-sort:: + Flag which, when set to "1", will sort the sections on the repository + listing by name. Set this flag to "0" if the order in the cgitrc file should + be preserved. Default value: "1". See also: section, + case-sensitive-sort, repository-sort. + +section-from-path:: + A number which, if defined prior to scan-path, specifies how many + path elements from each repo path to use as a default section name. + If negative, cgit will discard the specified number of path elements + above the repo directory. Default value: "0". + +side-by-side-diffs:: + If set to "1" shows side-by-side diffs instead of unidiffs per + default. Default value: "0". + +snapshots:: + Text which specifies the default set of snapshot formats that cgit + generates links for. The value is a space-separated list of zero or + more of the values "tar", "tar.gz", "tar.bz2", "tar.lz", "tar.xz", + "tar.zst" and "zip". The special value "all" enables all snapshot + formats. Default value: none. + All compressors use default settings. Some settings can be influenced + with environment variables, for example set ZSTD_CLEVEL=10 in web + server environment for higher (but slower) zstd compression. + +source-filter:: + Specifies a command which will be invoked to format plaintext blobs + in the tree view. The command will get the blob content on its STDIN + and the name of the blob as its only command line argument. The STDOUT + from the command will be included verbatim as the blob contents, i.e. + this can be used to implement e.g. syntax highlighting. Default value: + none. See also: "FILTER API". + +summary-branches:: + Specifies the number of branches to display in the repository "summary" + view. Default value: "10". + +summary-log:: + Specifies the number of log entries to display in the repository + "summary" view. Default value: "10". + +summary-tags:: + Specifies the number of tags to display in the repository "summary" + view. Default value: "10". + +strict-export:: + Filename which, if specified, needs to be present within the repository + for cgit to allow access to that repository. This can be used to emulate + gitweb's EXPORT_OK and STRICT_EXPORT functionality and limit cgit's + repositories to match those exported by git-daemon. This option must + be defined prior to scan-path. + +virtual-root:: + Url which, if specified, will be used as root for all cgit links. It + will also cause cgit to generate 'virtual urls', i.e. urls like + '/cgit/tree/README' as opposed to '?r=cgit&p=tree&path=README'. Default + value: none. + NOTE: cgit has recently learned how to use PATH_INFO to achieve the + same kind of virtual urls, so this option will probably be deprecated. + + +REPOSITORY SETTINGS +------------------- +repo.about-filter:: + Override the default about-filter. Default value: none. See also: + "enable-filter-overrides". See also: "FILTER API". + +repo.branch-sort:: + Flag which, when set to "age", enables date ordering in the branch ref + list, and when set to "name" enables ordering by branch name. Default + value: "name". + +repo.clone-url:: + A list of space-separated urls which can be used to clone this repo. + Default value: none. See also: "MACRO EXPANSION". + +repo.commit-filter:: + Override the default commit-filter. Default value: none. See also: + "enable-filter-overrides". See also: "FILTER API". + +repo.commit-sort:: + Flag which, when set to "date", enables strict date ordering in the + commit log, and when set to "topo" enables strict topological + ordering. If unset, the default ordering of "git log" is used. Default + value: unset. + +repo.defbranch:: + The name of the default branch for this repository. If no such branch + exists in the repository, the first branch name (when sorted) is used + as default instead. Default value: branch pointed to by HEAD, or + "master" if there is no suitable HEAD. + +repo.desc:: + The value to show as repository description. Default value: none. + +repo.email-filter:: + Override the default email-filter. Default value: none. See also: + "enable-filter-overrides". See also: "FILTER API". + +repo.enable-blame:: + A flag which can be used to disable the global setting + `enable-blame'. Default value: none. + +repo.enable-commit-graph:: + A flag which can be used to disable the global setting + `enable-commit-graph'. Default value: none. + +repo.enable-html-serving:: + A flag which can be used to override the global setting + `enable-html-serving`. Default value: none. + +repo.enable-log-filecount:: + A flag which can be used to disable the global setting + `enable-log-filecount'. Default value: none. + +repo.enable-log-linecount:: + A flag which can be used to disable the global setting + `enable-log-linecount'. Default value: none. + +repo.enable-remote-branches:: + Flag which, when set to "1", will make cgit display remote branches + in the summary and refs views. Default value: <enable-remote-branches>. + +repo.enable-subject-links:: + A flag which can be used to override the global setting + `enable-subject-links'. Default value: none. + +repo.extra-head-content:: + This value will be added verbatim to the head section of each page + displayed for this repo. Default value: none. + +repo.hide:: + Flag which, when set to "1", hides the repository from the repository + index. The repository can still be accessed by providing a direct path. + Default value: "0". See also: "repo.ignore". + +repo.homepage:: + The value to show as repository homepage. Default value: none. + +repo.ignore:: + Flag which, when set to "1", ignores the repository. The repository + is not shown in the index and cannot be accessed by providing a direct + path. Default value: "0". See also: "repo.hide". + +repo.logo:: + Url which specifies the source of an image which will be used as a logo + on this repo's pages. Default value: global logo. + +repo.logo-link:: + Url loaded when clicking on the cgit logo image. If unspecified the + calculated url of the repository index page will be used. Default + value: global logo-link. + +repo.module-link:: + Text which will be used as the formatstring for a hyperlink when a + submodule is printed in a directory listing. The arguments for the + formatstring are the path and SHA1 of the submodule commit. Default + value: <module-link> + +repo.module-link.<path>:: + Text which will be used as the formatstring for a hyperlink when a + submodule with the specified subdirectory path is printed in a + directory listing. The only argument for the formatstring is the SHA1 + of the submodule commit. Default value: none. + +repo.max-stats:: + Override the default maximum statistics period. Valid values are equal + to the values specified for the global "max-stats" setting. Default + value: none. + +repo.name:: + The value to show as repository name. Default value: <repo.url>. + +repo.owner:: + A value used to identify the owner of the repository. Default value: + none. + +repo.owner-filter:: + Override the default owner-filter. Default value: none. See also: + "enable-filter-overrides". See also: "FILTER API". + +repo.path:: + An absolute path to the repository directory. For non-bare repositories + this is the .git-directory. Default value: none. + +repo.readme:: + A path (relative to <repo.path>) which specifies a file to include + verbatim as the "About" page for this repo. You may also specify a + git refspec by head or by hash by prepending the refspec followed by + a colon. For example, "master:docs/readme.mkd". If the value begins + with a colon, i.e. ":docs/readme.rst", the head giving in query or + the default branch of the repository will be used. Sharing any file + will expose that entire directory tree to the "/about/PATH" endpoints, + so be sure that there are no non-public files located in the same + directory as the readme file. Default value: <readme>. + +repo.section:: + Override the current section name for this repository. Default value: + none. + +repo.snapshots:: + A mask of snapshot formats for this repo that cgit generates links for, + restricted by the global "snapshots" setting. Default value: + <snapshots>. + +repo.snapshot-prefix:: + Prefix to use for snapshot links instead of the repository basename. + For example, the "linux-stable" repository may wish to set this to + "linux" so that snapshots are in the format "linux-3.15.4" instead + of "linux-stable-3.15.4". Default value: <empty> meaning to use + the repository basename. + +repo.source-filter:: + Override the default source-filter. Default value: none. See also: + "enable-filter-overrides". See also: "FILTER API". + +repo.url:: + The relative url used to access the repository. This must be the first + setting specified for each repo. Default value: none. + + +REPOSITORY-SPECIFIC CGITRC FILE +------------------------------- +When the option "scan-path" is used to auto-discover git repositories, cgit +will try to parse the file "cgitrc" within any found repository. Such a +repo-specific config file may contain any of the repo-specific options +described above, except "repo.url" and "repo.path". Additionally, the "filter" +options are only acknowledged in repo-specific config files when +"enable-filter-overrides" is set to "1". + +Note: the "repo." prefix is dropped from the option names in repo-specific +config files, e.g. "repo.desc" becomes "desc". + + +FILTER API +---------- +By default, filters are separate processes that are executed each time they +are needed. Alternative technologies may be used by prefixing the filter +specification with the relevant string; available values are: + +'exec:':: + The default "one process per filter" mode. + + +Parameters are provided to filters as follows. + +about filter:: + This filter is given a single parameter: the filename of the source + file to filter. The filter can use the filename to determine (for + example) the type of syntax to follow when formatting the readme file. + The about text that is to be filtered is available on standard input + and the filtered text is expected on standard output. + +auth filter:: + The authentication filter receives 12 parameters: + - filter action, explained below, which specifies which action the + filter is called for + - http cookie + - http method + - http referer + - http path + - http https flag + - cgit repo + - cgit page + - cgit url + - cgit login url + When the filter action is "body", this filter must write to output the + HTML for displaying the login form, which POSTs to the login url. When + the filter action is "authenticate-cookie", this filter must validate + the http cookie and return a 0 if it is invalid or 1 if it is invalid, + in the exit code / close function. If the filter action is + "authenticate-post", this filter receives POST'd parameters on + standard input, and should write a complete CGI response, preferably + with a 302 redirect, and write to output one or more "Set-Cookie" + HTTP headers, each followed by a newline. + +commit filter:: + This filter is given no arguments. The commit message text that is to + be filtered is available on standard input and the filtered text is + expected on standard output. + +email filter:: + This filter is given two parameters: the email address of the relevant + author and a string indicating the originating page. The filter will + then receive the text string to format on standard input and is + expected to write to standard output the formatted text to be included + in the page. + +owner filter:: + This filter is given no arguments. The owner text is available on + standard input and the filter is expected to write to standard + output. The output is included in the Owner column. + +source filter:: + This filter is given a single parameter: the filename of the source + file to filter. The filter can use the filename to determine (for + example) the syntax highlighting mode. The contents of the source + file that is to be filtered is available on standard input and the + filtered contents is expected on standard output. + + +All filters are handed the following environment variables: + +- CGIT_REPO_URL (from repo.url) +- CGIT_REPO_NAME (from repo.name) +- CGIT_REPO_PATH (from repo.path) +- CGIT_REPO_OWNER (from repo.owner) +- CGIT_REPO_DEFBRANCH (from repo.defbranch) +- CGIT_REPO_SECTION (from repo.section) +- CGIT_REPO_CLONE_URL (from repo.clone-url) + +If a setting is not defined for a repository and the corresponding global +setting is also not defined (if applicable), then the corresponding +environment variable will be unset. + + +MACRO EXPANSION +--------------- +The following cgitrc options support a simple macro expansion feature, +where tokens prefixed with "$" are replaced with the value of a similarly +named environment variable: + +- cache-root +- include +- project-list +- scan-path + +Macro expansion will also happen on the content of $CGIT_CONFIG, if +defined. + +One usage of this feature is virtual hosting, which in its simplest form +can be accomplished by adding the following line to /etc/cgitrc: + + include=/etc/cgitrc.d/$HTTP_HOST + +The following options are expanded during request processing, and support +the environment variables defined in "FILTER API": + +- clone-url +- repo.clone-url + + +CACHE +----- + +All cache ttl values are in minutes. Negative ttl values indicate that a page +type will never expire, and thus the first time a URL is accessed, the result +will be cached indefinitely, even if the underlying git repository changes. +Conversely, when a ttl value is zero, the cache is disabled for that +particular page type, and the page type is never cached. + +SIGNATURES +---------- + +Cgit can host .asc signatures corresponding to various snapshot formats, +through use of git notes. For example, the following command may be used to +add a signature to a .tar.xz archive: + + git notes --ref=refs/notes/signatures/tar.xz add -C "$( + gpg --output - --armor --detach-sign cgit-1.1.tar.xz | + git hash-object -w --stdin + )" v1.1 + +If it is instead desirable to attach a signature of the underlying .tar, this +will be linked, as a special case, beside a .tar.* link that does not have its +own signature. For example, a signature of a tarball of the latest tag might +be added with a similar command: + + tag="$(git describe --abbrev=0)" + git notes --ref=refs/notes/signatures/tar add -C "$( + git archive --format tar --prefix "cgit-${tag#v}/" "$tag" | + gpg --output - --armor --detach-sign | + git hash-object -w --stdin + )" "$tag" + +Since git-archive(1) is expected to produce stable output between versions, +this allows one to generate a long-term signature of the contents of a given +tag. + +EXAMPLE CGITRC FILE +------------------- + +.... +# Enable caching of up to 1000 output entries +cache-size=1000 + + +# Specify some default clone urls using macro expansion +clone-url=git://foo.org/$CGIT_REPO_URL git@foo.org:$CGIT_REPO_URL + +# Specify the css url +css=/css/cgit.css + + +# Show owner on index page +enable-index-owner=1 + + +# Allow http transport git clone +enable-http-clone=1 + + +# Show extra links for each repository on the index page +enable-index-links=1 + + +# Enable blame page and create links to it from tree page +enable-blame=1 + + +# Enable ASCII art commit history graph on the log pages +enable-commit-graph=1 + + +# Show number of affected files per commit on the log pages +enable-log-filecount=1 + + +# Show number of added/removed lines per commit on the log pages +enable-log-linecount=1 + + +# Sort branches by date +branch-sort=age + + +# Add a cgit favicon +favicon=/favicon.ico + + +# Use a custom logo +logo=/img/mylogo.png + + +# Enable statistics per week, month and quarter +max-stats=quarter + + +# Set the title and heading of the repository index page +root-title=example.com git repositories + + +# Set a subheading for the repository index page +root-desc=tracking the foobar development + + +# Include some more info about example.com on the index page +root-readme=/var/www/htdocs/about.html + + +# Allow download of tar.gz, tar.bz2 and zip-files +snapshots=tar.gz tar.bz2 zip + + +## +## List of common mimetypes +## + +mimetype.gif=image/gif +mimetype.html=text/html +mimetype.jpg=image/jpeg +mimetype.jpeg=image/jpeg +mimetype.pdf=application/pdf +mimetype.png=image/png +mimetype.svg=image/svg+xml + + +# Highlight source code with python pygments-based highlighter +source-filter=/var/www/cgit/filters/syntax-highlighting.py + +# Format markdown, restructuredtext, manpages, text files, and html files +# through the right converters +about-filter=/var/www/cgit/filters/about-formatting.sh + +## +## Search for these files in the root of the default branch of repositories +## for coming up with the about page: +## +readme=:README.md +readme=:readme.md +readme=:README.mkd +readme=:readme.mkd +readme=:README.rst +readme=:readme.rst +readme=:README.html +readme=:readme.html +readme=:README.htm +readme=:readme.htm +readme=:README.txt +readme=:readme.txt +readme=:README +readme=:readme +readme=:INSTALL.md +readme=:install.md +readme=:INSTALL.mkd +readme=:install.mkd +readme=:INSTALL.rst +readme=:install.rst +readme=:INSTALL.html +readme=:install.html +readme=:INSTALL.htm +readme=:install.htm +readme=:INSTALL.txt +readme=:install.txt +readme=:INSTALL +readme=:install + + +## +## List of repositories. +## PS: Any repositories listed when section is unset will not be +## displayed under a section heading +## PPS: This list could be kept in a different file (e.g. '/etc/cgitrepos') +## and included like this: +## include=/etc/cgitrepos +## + + +repo.url=foo +repo.path=/pub/git/foo.git +repo.desc=the master foo repository +repo.owner=fooman@example.com +repo.readme=info/web/about.html + + +repo.url=bar +repo.path=/pub/git/bar.git +repo.desc=the bars for your foo +repo.owner=barman@example.com +repo.readme=info/web/about.html + + +# The next repositories will be displayed under the 'extras' heading +section=extras + + +repo.url=baz +repo.path=/pub/git/baz.git +repo.desc=a set of extensions for bar users + +repo.url=wiz +repo.path=/pub/git/wiz.git +repo.desc=the wizard of foo + + +# Add some mirrored repositories +section=mirrors + + +repo.url=git +repo.path=/pub/git/git.git +repo.desc=the dscm + + +repo.url=linux +repo.path=/pub/git/linux.git +repo.desc=the kernel + +# Disable adhoc downloads of this repo +repo.snapshots=0 + +# Disable line-counts for this repo +repo.enable-log-linecount=0 + +# Restrict the max statistics period for this repo +repo.max-stats=month +.... + + +BUGS +---- +Comments currently cannot appear on the same line as a setting; the comment +will be included as part of the value. E.g. this line: + + robots=index # allow indexing + +will generate the following html element: + + <meta name='robots' content='index # allow indexing'/> + + + +AUTHOR +------ +Lars Hjemli <hjemli@gmail.com> +Jason A. Donenfeld <Jason@zx2c4.com> diff --git a/third_party/cgit/cmd.c b/third_party/cgit/cmd.c new file mode 100644 index 0000000000..c664e894f7 --- /dev/null +++ b/third_party/cgit/cmd.c @@ -0,0 +1,186 @@ +/* cmd.c: the cgit command dispatcher + * + * Copyright (C) 2006-2017 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "cmd.h" +#include "cache.h" +#include "ui-shared.h" +#include "ui-atom.h" +#include "ui-blame.h" +#include "ui-blob.h" +#include "ui-clone.h" +#include "ui-commit.h" +#include "ui-diff.h" +#include "ui-log.h" +#include "ui-patch.h" +#include "ui-plain.h" +#include "ui-refs.h" +#include "ui-repolist.h" +#include "ui-snapshot.h" +#include "ui-stats.h" +#include "ui-summary.h" +#include "ui-tag.h" +#include "ui-tree.h" + +static void HEAD_fn(void) +{ + cgit_clone_head(); +} + +static void atom_fn(void) +{ + cgit_print_atom(ctx.qry.head, ctx.qry.path, ctx.cfg.max_atom_items); +} + +static void about_fn(void) +{ + cgit_print_repo_readme(ctx.qry.path); +} + +static void blame_fn(void) +{ + if (ctx.repo->enable_blame) + cgit_print_blame(); + else + cgit_print_error_page(403, "Forbidden", "Blame is disabled"); +} + +static void blob_fn(void) +{ + cgit_print_blob(ctx.qry.oid, ctx.qry.path, ctx.qry.head, 0); +} + +static void commit_fn(void) +{ + cgit_print_commit(ctx.qry.oid, ctx.qry.path); +} + +static void diff_fn(void) +{ + cgit_print_diff(ctx.qry.oid, ctx.qry.oid2, ctx.qry.path, 1, 0); +} + +static void rawdiff_fn(void) +{ + cgit_print_diff(ctx.qry.oid, ctx.qry.oid2, ctx.qry.path, 1, 1); +} + +static void info_fn(void) +{ + cgit_clone_info(); +} + +static void log_fn(void) +{ + cgit_print_log(ctx.qry.oid, ctx.qry.ofs, ctx.cfg.max_commit_count, + ctx.qry.grep, ctx.qry.search, ctx.qry.path, 1, + ctx.repo->enable_commit_graph, + ctx.repo->commit_sort); +} + +static void ls_cache_fn(void) +{ + ctx.page.mimetype = "text/plain"; + ctx.page.filename = "ls-cache.txt"; + cgit_print_http_headers(); + cache_ls(ctx.cfg.cache_root); +} + +static void objects_fn(void) +{ + cgit_clone_objects(); +} + +static void repolist_fn(void) +{ + cgit_print_repolist(); +} + +static void patch_fn(void) +{ + cgit_print_patch(ctx.qry.oid, ctx.qry.oid2, ctx.qry.path); +} + +static void plain_fn(void) +{ + cgit_print_plain(); +} + +static void refs_fn(void) +{ + cgit_print_refs(); +} + +static void snapshot_fn(void) +{ + cgit_print_snapshot(ctx.qry.head, ctx.qry.oid, ctx.qry.path, + ctx.qry.nohead); +} + +static void stats_fn(void) +{ + cgit_show_stats(); +} + +static void summary_fn(void) +{ + cgit_print_summary(); +} + +static void tag_fn(void) +{ + cgit_print_tag(ctx.qry.oid); +} + +static void tree_fn(void) +{ + cgit_print_tree(ctx.qry.oid, ctx.qry.path); +} + +#define def_cmd(name, want_repo, want_vpath, is_clone) \ + {#name, name##_fn, want_repo, want_vpath, is_clone} + +struct cgit_cmd *cgit_get_cmd(void) +{ + static struct cgit_cmd cmds[] = { + def_cmd(HEAD, 1, 0, 1), + def_cmd(atom, 1, 0, 0), + def_cmd(about, 1, 1, 0), + def_cmd(blame, 1, 1, 0), + def_cmd(blob, 1, 0, 0), + def_cmd(commit, 1, 1, 0), + def_cmd(diff, 1, 1, 0), + def_cmd(info, 1, 0, 1), + def_cmd(log, 1, 1, 0), + def_cmd(ls_cache, 0, 0, 0), + def_cmd(objects, 1, 0, 1), + def_cmd(patch, 1, 1, 0), + def_cmd(plain, 1, 0, 0), + def_cmd(rawdiff, 1, 1, 0), + def_cmd(refs, 1, 0, 0), + def_cmd(repolist, 0, 0, 0), + def_cmd(snapshot, 1, 0, 0), + def_cmd(stats, 1, 1, 0), + def_cmd(summary, 1, 0, 0), + def_cmd(tag, 1, 0, 0), + def_cmd(tree, 1, 1, 0), + }; + int i; + + if (ctx.qry.page == NULL) { + if (ctx.repo) + ctx.qry.page = "summary"; + else + ctx.qry.page = "repolist"; + } + + for (i = 0; i < sizeof(cmds)/sizeof(*cmds); i++) + if (!strcmp(ctx.qry.page, cmds[i].name)) + return &cmds[i]; + return NULL; +} diff --git a/third_party/cgit/cmd.h b/third_party/cgit/cmd.h new file mode 100644 index 0000000000..6249b1d892 --- /dev/null +++ b/third_party/cgit/cmd.h @@ -0,0 +1,16 @@ +#ifndef CMD_H +#define CMD_H + +typedef void (*cgit_cmd_fn)(void); + +struct cgit_cmd { + const char *name; + cgit_cmd_fn fn; + unsigned int want_repo:1, + want_vpath:1, + is_clone:1; +}; + +extern struct cgit_cmd *cgit_get_cmd(void); + +#endif /* CMD_H */ diff --git a/third_party/cgit/configfile.c b/third_party/cgit/configfile.c new file mode 100644 index 0000000000..e0391091e1 --- /dev/null +++ b/third_party/cgit/configfile.c @@ -0,0 +1,90 @@ +/* configfile.c: parsing of config files + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include <git-compat-util.h> +#include "configfile.h" + +static int next_char(FILE *f) +{ + int c = fgetc(f); + if (c == '\r') { + c = fgetc(f); + if (c != '\n') { + ungetc(c, f); + c = '\r'; + } + } + return c; +} + +static void skip_line(FILE *f) +{ + int c; + + while ((c = next_char(f)) && c != '\n' && c != EOF) + ; +} + +static int read_config_line(FILE *f, struct strbuf *name, struct strbuf *value) +{ + int c = next_char(f); + + strbuf_reset(name); + strbuf_reset(value); + + /* Skip comments and preceding spaces. */ + for(;;) { + if (c == EOF) + return 0; + else if (c == '#' || c == ';') + skip_line(f); + else if (!isspace(c)) + break; + c = next_char(f); + } + + /* Read variable name. */ + while (c != '=') { + if (c == '\n' || c == EOF) + return 0; + strbuf_addch(name, c); + c = next_char(f); + } + + /* Read variable value. */ + c = next_char(f); + while (c != '\n' && c != EOF) { + strbuf_addch(value, c); + c = next_char(f); + } + + return 1; +} + +int parse_configfile(const char *filename, configfile_value_fn fn) +{ + static int nesting; + struct strbuf name = STRBUF_INIT; + struct strbuf value = STRBUF_INIT; + FILE *f; + + /* cancel deeply nested include-commands */ + if (nesting > 8) + return -1; + if (!(f = fopen(filename, "r"))) + return -1; + nesting++; + while (read_config_line(f, &name, &value)) + fn(name.buf, value.buf); + nesting--; + fclose(f); + strbuf_release(&name); + strbuf_release(&value); + return 0; +} + diff --git a/third_party/cgit/configfile.h b/third_party/cgit/configfile.h new file mode 100644 index 0000000000..af7ca19735 --- /dev/null +++ b/third_party/cgit/configfile.h @@ -0,0 +1,10 @@ +#ifndef CONFIGFILE_H +#define CONFIGFILE_H + +#include "cgit.h" + +typedef void (*configfile_value_fn)(const char *name, const char *value); + +extern int parse_configfile(const char *filename, configfile_value_fn fn); + +#endif /* CONFIGFILE_H */ diff --git a/third_party/cgit/contrib/hooks/post-receive.agefile b/third_party/cgit/contrib/hooks/post-receive.agefile new file mode 100755 index 0000000000..2f72ae9c0d --- /dev/null +++ b/third_party/cgit/contrib/hooks/post-receive.agefile @@ -0,0 +1,19 @@ +#!/bin/sh +# +# An example hook to update the "agefile" for CGit's idle time calculation. +# +# This hook assumes that you are using the default agefile location of +# "info/web/last-modified". If you change the value in your cgitrc then you +# must also change it here. +# +# To install the hook, copy (or link) it to the file "hooks/post-receive" in +# each of your repositories. +# + +agefile="$(git rev-parse --git-dir)"/info/web/last-modified + +mkdir -p "$(dirname "$agefile")" && +git for-each-ref \ + --sort=-authordate --count=1 \ + --format='%(authordate:iso8601)' \ + >"$agefile" diff --git a/third_party/cgit/default.nix b/third_party/cgit/default.nix new file mode 100644 index 0000000000..c783bda16e --- /dev/null +++ b/third_party/cgit/default.nix @@ -0,0 +1,51 @@ +{ depot, lib, pkgs, ... }: + +let + inherit (pkgs) stdenv gzip bzip2 xz lzip zstd zlib openssl; +in +stdenv.mkDerivation rec { + pname = "cgit-pink"; + version = "master"; + src = ./.; + + buildInputs = [ openssl zlib ]; + + enableParallelBuilding = true; + + postPatch = '' + sed -e 's|"gzip"|"${gzip}/bin/gzip"|' \ + -e 's|"bzip2"|"${bzip2.bin}/bin/bzip2"|' \ + -e 's|"lzip"|"${lzip}/bin/lzip"|' \ + -e 's|"xz"|"${xz.bin}/bin/xz"|' \ + -e 's|"zstd"|"${zstd}/bin/zstd"|' \ + -i ui-snapshot.c + ''; + + # Give cgit the git source tree including depot patches. Note that + # the version expected by cgit should be kept in sync with the + # version available in nixpkgs. + # + # TODO(tazjin): Add an assert for this somewhere so we notice it on + # channel bumps. + preBuild = '' + rm -rf git # remove submodule dir ... + cp -r --no-preserve=ownership,mode ${pkgs.srcOnly depot.third_party.git} git + makeFlagsArray+=(prefix="$out" CGIT_SCRIPT_PATH="$out/cgit/") + cat tvl-extra.css >> cgit.css + ''; + + stripDebugList = [ "cgit" ]; + + # We don't use the filters and they require wrapping to find their deps + postInstall = '' + rm -rf "$out/lib/cgit/filters" + find "$out" -type d -empty -delete + ''; + + meta = { + hompepage = "https://git.causal.agency/cgit-pink/"; + description = "cgit fork aiming for better maintenance"; + license = lib.licenses.gpl2; + platforms = lib.platforms.linux; + }; +} diff --git a/third_party/cgit/filter.c b/third_party/cgit/filter.c new file mode 100644 index 0000000000..190fb5501b --- /dev/null +++ b/third_party/cgit/filter.c @@ -0,0 +1,222 @@ +/* filter.c: filter framework functions + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "html.h" + +static inline void reap_filter(struct cgit_filter *filter) +{ + if (filter && filter->cleanup) + filter->cleanup(filter); +} + +void cgit_cleanup_filters(void) +{ + int i; + reap_filter(ctx.cfg.about_filter); + reap_filter(ctx.cfg.commit_filter); + reap_filter(ctx.cfg.source_filter); + reap_filter(ctx.cfg.email_filter); + reap_filter(ctx.cfg.owner_filter); + reap_filter(ctx.cfg.auth_filter); + for (i = 0; i < cgit_repolist.count; ++i) { + reap_filter(cgit_repolist.repos[i].about_filter); + reap_filter(cgit_repolist.repos[i].commit_filter); + reap_filter(cgit_repolist.repos[i].source_filter); + reap_filter(cgit_repolist.repos[i].email_filter); + reap_filter(cgit_repolist.repos[i].owner_filter); + } +} + +static int open_exec_filter(struct cgit_filter *base, va_list ap) +{ + struct cgit_exec_filter *filter = (struct cgit_exec_filter *)base; + int pipe_fh[2]; + int i; + + for (i = 0; i < filter->base.argument_count; i++) + filter->argv[i + 1] = va_arg(ap, char *); + + chk_zero(fflush(stdout), "unable to flush STDOUT"); + filter->old_stdout = chk_positive(dup(STDOUT_FILENO), + "Unable to duplicate STDOUT"); + chk_zero(pipe(pipe_fh), "Unable to create pipe to subprocess"); + filter->pid = chk_non_negative(fork(), "Unable to create subprocess"); + if (filter->pid == 0) { + close(pipe_fh[1]); + chk_non_negative(dup2(pipe_fh[0], STDIN_FILENO), + "Unable to use pipe as STDIN"); + execvp(filter->cmd, filter->argv); + die_errno("Unable to exec subprocess %s", filter->cmd); + } + close(pipe_fh[0]); + chk_non_negative(dup2(pipe_fh[1], STDOUT_FILENO), + "Unable to use pipe as STDOUT"); + close(pipe_fh[1]); + return 0; +} + +static int close_exec_filter(struct cgit_filter *base) +{ + struct cgit_exec_filter *filter = (struct cgit_exec_filter *)base; + int i, exit_status = 0; + + chk_zero(fflush(stdout), "unable to flush STDOUT"); + chk_non_negative(dup2(filter->old_stdout, STDOUT_FILENO), + "Unable to restore STDOUT"); + close(filter->old_stdout); + if (filter->pid < 0) + goto done; + waitpid(filter->pid, &exit_status, 0); + if (WIFEXITED(exit_status)) + goto done; + die("Subprocess %s exited abnormally", filter->cmd); + +done: + for (i = 0; i < filter->base.argument_count; i++) + filter->argv[i + 1] = NULL; + return WEXITSTATUS(exit_status); + +} + +static void fprintf_exec_filter(struct cgit_filter *base, FILE *f, const char *prefix) +{ + struct cgit_exec_filter *filter = (struct cgit_exec_filter *)base; + fprintf(f, "%sexec:%s\n", prefix, filter->cmd); +} + +static void cleanup_exec_filter(struct cgit_filter *base) +{ + struct cgit_exec_filter *filter = (struct cgit_exec_filter *)base; + if (filter->argv) { + free(filter->argv); + filter->argv = NULL; + } + if (filter->cmd) { + free(filter->cmd); + filter->cmd = NULL; + } +} + +static struct cgit_filter *new_exec_filter(const char *cmd, int argument_count) +{ + struct cgit_exec_filter *f; + int args_size = 0; + + f = xmalloc(sizeof(*f)); + /* We leave argv for now and assign it below. */ + cgit_exec_filter_init(f, xstrdup(cmd), NULL); + f->base.argument_count = argument_count; + args_size = (2 + argument_count) * sizeof(char *); + f->argv = xmalloc(args_size); + memset(f->argv, 0, args_size); + f->argv[0] = f->cmd; + return &f->base; +} + +void cgit_exec_filter_init(struct cgit_exec_filter *filter, char *cmd, char **argv) +{ + memset(filter, 0, sizeof(*filter)); + filter->base.open = open_exec_filter; + filter->base.close = close_exec_filter; + filter->base.fprintf = fprintf_exec_filter; + filter->base.cleanup = cleanup_exec_filter; + filter->cmd = cmd; + filter->argv = argv; + /* The argument count for open_filter is zero by default, unless called from new_filter, above. */ + filter->base.argument_count = 0; +} + +int cgit_open_filter(struct cgit_filter *filter, ...) +{ + int result; + va_list ap; + if (!filter) + return 0; + va_start(ap, filter); + result = filter->open(filter, ap); + va_end(ap); + return result; +} + +int cgit_close_filter(struct cgit_filter *filter) +{ + if (!filter) + return 0; + return filter->close(filter); +} + +void cgit_fprintf_filter(struct cgit_filter *filter, FILE *f, const char *prefix) +{ + (filter->fprintf)(filter, f, prefix); +} + + + +static const struct { + const char *prefix; + struct cgit_filter *(*ctor)(const char *cmd, int argument_count); +} filter_specs[] = { + { "exec", new_exec_filter }, +}; + +struct cgit_filter *cgit_new_filter(const char *cmd, filter_type filtertype) +{ + char *colon; + int i; + size_t len; + int argument_count; + + if (!cmd || !cmd[0]) + return NULL; + + colon = strchr(cmd, ':'); + len = colon - cmd; + /* + * In case we're running on Windows, don't allow a single letter before + * the colon. + */ + if (len == 1) + colon = NULL; + + switch (filtertype) { + case AUTH: + argument_count = 12; + break; + + case EMAIL: + argument_count = 2; + break; + + case OWNER: + argument_count = 0; + break; + + case SOURCE: + case ABOUT: + argument_count = 1; + break; + + case COMMIT: + default: + argument_count = 0; + break; + } + + /* If no prefix is given, exec filter is the default. */ + if (!colon) + return new_exec_filter(cmd, argument_count); + + for (i = 0; i < ARRAY_SIZE(filter_specs); i++) { + if (len == strlen(filter_specs[i].prefix) && + !strncmp(filter_specs[i].prefix, cmd, len)) + return filter_specs[i].ctor(colon + 1, argument_count); + } + + die("Invalid filter type: %.*s", (int) len, cmd); +} diff --git a/third_party/cgit/filters/about-formatting.sh b/third_party/cgit/filters/about-formatting.sh new file mode 100755 index 0000000000..85daf9c26b --- /dev/null +++ b/third_party/cgit/filters/about-formatting.sh @@ -0,0 +1,27 @@ +#!/bin/sh + +# This may be used with the about-filter or repo.about-filter setting in cgitrc. +# It passes formatting of about pages to differing programs, depending on the usage. + +# Markdown support requires python and markdown-python. +# RestructuredText support requires python and docutils. +# Man page support requires groff. + +# The following environment variables can be used to retrieve the configuration +# of the repository for which this script is called: +# CGIT_REPO_URL ( = repo.url setting ) +# CGIT_REPO_NAME ( = repo.name setting ) +# CGIT_REPO_PATH ( = repo.path setting ) +# CGIT_REPO_OWNER ( = repo.owner setting ) +# CGIT_REPO_DEFBRANCH ( = repo.defbranch setting ) +# CGIT_REPO_SECTION ( = section setting ) +# CGIT_REPO_CLONE_URL ( = repo.clone-url setting ) + +cd "$(dirname $0)/html-converters/" +case "$(printf '%s' "$1" | tr '[:upper:]' '[:lower:]')" in + *.markdown|*.mdown|*.md|*.mkd) exec ./md2html; ;; + *.rst) exec ./rst2html; ;; + *.[1-9]) exec ./man2html; ;; + *.htm|*.html) exec cat; ;; + *.txt|*) exec ./txt2html; ;; +esac diff --git a/third_party/cgit/filters/commit-links.sh b/third_party/cgit/filters/commit-links.sh new file mode 100755 index 0000000000..796ac308d2 --- /dev/null +++ b/third_party/cgit/filters/commit-links.sh @@ -0,0 +1,28 @@ +#!/bin/sh +# This script can be used to generate links in commit messages. +# +# To use this script, refer to this file with either the commit-filter or the +# repo.commit-filter options in cgitrc. +# +# The following environment variables can be used to retrieve the configuration +# of the repository for which this script is called: +# CGIT_REPO_URL ( = repo.url setting ) +# CGIT_REPO_NAME ( = repo.name setting ) +# CGIT_REPO_PATH ( = repo.path setting ) +# CGIT_REPO_OWNER ( = repo.owner setting ) +# CGIT_REPO_DEFBRANCH ( = repo.defbranch setting ) +# CGIT_REPO_SECTION ( = section setting ) +# CGIT_REPO_CLONE_URL ( = repo.clone-url setting ) +# + +regex='' + +# This expression generates links to commits referenced by their SHA1. +regex=$regex' +s|\b([0-9a-fA-F]{7,64})\b|<a href="./?id=\1">\1</a>|g' + +# This expression generates links to a fictional bugtracker. +regex=$regex' +s|#([0-9]+)\b|<a href="http://bugs.example.com/?bug=\1">#\1</a>|g' + +sed -re "$regex" diff --git a/third_party/cgit/filters/email-gravatar.py b/third_party/cgit/filters/email-gravatar.py new file mode 100755 index 0000000000..012113c591 --- /dev/null +++ b/third_party/cgit/filters/email-gravatar.py @@ -0,0 +1,36 @@ +#!/usr/bin/env python3 + +# This script may be used with the email-filter or repo.email-filter settings in cgitrc. +# +# The following environment variables can be used to retrieve the configuration +# of the repository for which this script is called: +# CGIT_REPO_URL ( = repo.url setting ) +# CGIT_REPO_NAME ( = repo.name setting ) +# CGIT_REPO_PATH ( = repo.path setting ) +# CGIT_REPO_OWNER ( = repo.owner setting ) +# CGIT_REPO_DEFBRANCH ( = repo.defbranch setting ) +# CGIT_REPO_SECTION ( = section setting ) +# CGIT_REPO_CLONE_URL ( = repo.clone-url setting ) +# +# It receives an email address on argv[1] and text on stdin. It prints +# to stdout that text prepended by a gravatar at 10pt. + +import sys +import hashlib +import codecs + +email = sys.argv[1].lower().strip() +if email[0] == '<': + email = email[1:] +if email[-1] == '>': + email = email[0:-1] + +page = sys.argv[2] + +sys.stdin = codecs.getreader("utf-8")(sys.stdin.detach()) +sys.stdout = codecs.getwriter("utf-8")(sys.stdout.detach()) + +md5 = hashlib.md5(email.encode()).hexdigest() +text = sys.stdin.read().strip() + +print("<img src='//www.gravatar.com/avatar/" + md5 + "?s=13&d=retro' width='13' height='13' alt='Gravatar' /> " + text) diff --git a/third_party/cgit/filters/html-converters/man2html b/third_party/cgit/filters/html-converters/man2html new file mode 100755 index 0000000000..0ef7884181 --- /dev/null +++ b/third_party/cgit/filters/html-converters/man2html @@ -0,0 +1,4 @@ +#!/bin/sh +echo "<div style=\"font-family: monospace\">" +groff -mandoc -T html -P -r -P -l | egrep -v '(<html>|<head>|<meta|<title>|</title>|</head>|<body>|</body>|</html>|<!DOCTYPE|"http://www.w3.org)' +echo "</div>" diff --git a/third_party/cgit/filters/html-converters/md2html b/third_party/cgit/filters/html-converters/md2html new file mode 100755 index 0000000000..59f43a8416 --- /dev/null +++ b/third_party/cgit/filters/html-converters/md2html @@ -0,0 +1,304 @@ +#!/usr/bin/env python3 +import markdown +import sys +import io +from pygments.formatters import HtmlFormatter +from markdown.extensions.toc import TocExtension +sys.stdin = io.TextIOWrapper(sys.stdin.buffer, encoding='utf-8') +sys.stdout = io.TextIOWrapper(sys.stdout.buffer, encoding='utf-8') +sys.stdout.write(''' +<style> +.markdown-body { + font-size: 14px; + line-height: 1.6; + overflow: hidden; +} +.markdown-body>*:first-child { + margin-top: 0 !important; +} +.markdown-body>*:last-child { + margin-bottom: 0 !important; +} +.markdown-body a.absent { + color: #c00; +} +.markdown-body a.anchor { + display: block; + padding-left: 30px; + margin-left: -30px; + cursor: pointer; + position: absolute; + top: 0; + left: 0; + bottom: 0; +} +.markdown-body h1, .markdown-body h2, .markdown-body h3, .markdown-body h4, .markdown-body h5, .markdown-body h6 { + margin: 20px 0 10px; + padding: 0; + font-weight: bold; + -webkit-font-smoothing: antialiased; + cursor: text; + position: relative; +} +.markdown-body h1 .mini-icon-link, .markdown-body h2 .mini-icon-link, .markdown-body h3 .mini-icon-link, .markdown-body h4 .mini-icon-link, .markdown-body h5 .mini-icon-link, .markdown-body h6 .mini-icon-link { + display: none; + color: #000; +} +.markdown-body h1:hover a.anchor, .markdown-body h2:hover a.anchor, .markdown-body h3:hover a.anchor, .markdown-body h4:hover a.anchor, .markdown-body h5:hover a.anchor, .markdown-body h6:hover a.anchor { + text-decoration: none; + line-height: 1; + padding-left: 0; + margin-left: -22px; + top: 15%; +} +.markdown-body h1:hover a.anchor .mini-icon-link, .markdown-body h2:hover a.anchor .mini-icon-link, .markdown-body h3:hover a.anchor .mini-icon-link, .markdown-body h4:hover a.anchor .mini-icon-link, .markdown-body h5:hover a.anchor .mini-icon-link, .markdown-body h6:hover a.anchor .mini-icon-link { + display: inline-block; +} +div#cgit .markdown-body h1 a.toclink, div#cgit .markdown-body h2 a.toclink, div#cgit .markdown-body h3 a.toclink, div#cgit .markdown-body h4 a.toclink, div#cgit .markdown-body h5 a.toclink, div#cgit .markdown-body h6 a.toclink { + color: black; +} +.markdown-body h1 tt, .markdown-body h1 code, .markdown-body h2 tt, .markdown-body h2 code, .markdown-body h3 tt, .markdown-body h3 code, .markdown-body h4 tt, .markdown-body h4 code, .markdown-body h5 tt, .markdown-body h5 code, .markdown-body h6 tt, .markdown-body h6 code { + font-size: inherit; +} +.markdown-body h1 { + font-size: 28px; + color: #000; +} +.markdown-body h2 { + font-size: 24px; + border-bottom: 1px solid #ccc; + color: #000; +} +.markdown-body h3 { + font-size: 18px; +} +.markdown-body h4 { + font-size: 16px; +} +.markdown-body h5 { + font-size: 14px; +} +.markdown-body h6 { + color: #777; + font-size: 14px; +} +.markdown-body p, .markdown-body blockquote, .markdown-body ul, .markdown-body ol, .markdown-body dl, .markdown-body table, .markdown-body pre { + margin: 15px 0; +} +.markdown-body hr { + border: 2px solid #ccc; +} +.markdown-body>h2:first-child, .markdown-body>h1:first-child, .markdown-body>h1:first-child+h2, .markdown-body>h3:first-child, .markdown-body>h4:first-child, .markdown-body>h5:first-child, .markdown-body>h6:first-child { + margin-top: 0; + padding-top: 0; +} +.markdown-body a:first-child h1, .markdown-body a:first-child h2, .markdown-body a:first-child h3, .markdown-body a:first-child h4, .markdown-body a:first-child h5, .markdown-body a:first-child h6 { + margin-top: 0; + padding-top: 0; +} +.markdown-body h1+p, .markdown-body h2+p, .markdown-body h3+p, .markdown-body h4+p, .markdown-body h5+p, .markdown-body h6+p { + margin-top: 0; +} +.markdown-body li p.first { + display: inline-block; +} +.markdown-body ul, .markdown-body ol { + padding-left: 30px; +} +.markdown-body ul.no-list, .markdown-body ol.no-list { + list-style-type: none; + padding: 0; +} +.markdown-body ul li>:first-child, .markdown-body ul li ul:first-of-type, .markdown-body ul li ol:first-of-type, .markdown-body ol li>:first-child, .markdown-body ol li ul:first-of-type, .markdown-body ol li ol:first-of-type { + margin-top: 0px; +} +.markdown-body ul li p:last-of-type, .markdown-body ol li p:last-of-type { + margin-bottom: 0; +} +.markdown-body ul ul, .markdown-body ul ol, .markdown-body ol ol, .markdown-body ol ul { + margin-bottom: 0; +} +.markdown-body dl { + padding: 0; +} +.markdown-body dl dt { + font-size: 14px; + font-weight: bold; + font-style: italic; + padding: 0; + margin: 15px 0 5px; +} +.markdown-body dl dt:first-child { + padding: 0; +} +.markdown-body dl dt>:first-child { + margin-top: 0px; +} +.markdown-body dl dt>:last-child { + margin-bottom: 0px; +} +.markdown-body dl dd { + margin: 0 0 15px; + padding: 0 15px; +} +.markdown-body dl dd>:first-child { + margin-top: 0px; +} +.markdown-body dl dd>:last-child { + margin-bottom: 0px; +} +.markdown-body blockquote { + border-left: 4px solid #DDD; + padding: 0 15px; + color: #777; +} +.markdown-body blockquote>:first-child { + margin-top: 0px; +} +.markdown-body blockquote>:last-child { + margin-bottom: 0px; +} +.markdown-body table th { + font-weight: bold; +} +.markdown-body table th, .markdown-body table td { + border: 1px solid #ccc; + padding: 6px 13px; +} +.markdown-body table tr { + border-top: 1px solid #ccc; + background-color: #fff; +} +.markdown-body table tr:nth-child(2n) { + background-color: #f8f8f8; +} +.markdown-body img { + max-width: 100%; + -moz-box-sizing: border-box; + box-sizing: border-box; +} +.markdown-body span.frame { + display: block; + overflow: hidden; +} +.markdown-body span.frame>span { + border: 1px solid #ddd; + display: block; + float: left; + overflow: hidden; + margin: 13px 0 0; + padding: 7px; + width: auto; +} +.markdown-body span.frame span img { + display: block; + float: left; +} +.markdown-body span.frame span span { + clear: both; + color: #333; + display: block; + padding: 5px 0 0; +} +.markdown-body span.align-center { + display: block; + overflow: hidden; + clear: both; +} +.markdown-body span.align-center>span { + display: block; + overflow: hidden; + margin: 13px auto 0; + text-align: center; +} +.markdown-body span.align-center span img { + margin: 0 auto; + text-align: center; +} +.markdown-body span.align-right { + display: block; + overflow: hidden; + clear: both; +} +.markdown-body span.align-right>span { + display: block; + overflow: hidden; + margin: 13px 0 0; + text-align: right; +} +.markdown-body span.align-right span img { + margin: 0; + text-align: right; +} +.markdown-body span.float-left { + display: block; + margin-right: 13px; + overflow: hidden; + float: left; +} +.markdown-body span.float-left span { + margin: 13px 0 0; +} +.markdown-body span.float-right { + display: block; + margin-left: 13px; + overflow: hidden; + float: right; +} +.markdown-body span.float-right>span { + display: block; + overflow: hidden; + margin: 13px auto 0; + text-align: right; +} +.markdown-body code, .markdown-body tt { + margin: 0 2px; + padding: 0px 5px; + border: 1px solid #eaeaea; + background-color: #f8f8f8; + border-radius: 3px; +} +.markdown-body code { + white-space: nowrap; +} +.markdown-body pre>code { + margin: 0; + padding: 0; + white-space: pre; + border: none; + background: transparent; +} +.markdown-body .highlight pre, .markdown-body pre { + background-color: #f8f8f8; + border: 1px solid #ccc; + font-size: 13px; + line-height: 19px; + overflow: auto; + padding: 6px 10px; + border-radius: 3px; +} +.markdown-body pre code, .markdown-body pre tt { + margin: 0; + padding: 0; + background-color: transparent; + border: none; +} +''') +sys.stdout.write(HtmlFormatter(style='pastie').get_style_defs('.highlight')) +sys.stdout.write(''' +</style> +''') +sys.stdout.write("<div class='markdown-body'>") +sys.stdout.flush() +# Note: you may want to run this through bleach for sanitization +markdown.markdownFromFile( + output_format="html5", + extensions=[ + "markdown.extensions.fenced_code", + "markdown.extensions.codehilite", + "markdown.extensions.tables", + "markdown.extensions.sane_lists", + TocExtension(anchorlink=True)], + extension_configs={ + "markdown.extensions.codehilite":{"css_class":"highlight"}}) +sys.stdout.write("</div>") diff --git a/third_party/cgit/filters/html-converters/rst2html b/third_party/cgit/filters/html-converters/rst2html new file mode 100755 index 0000000000..02d90f81c9 --- /dev/null +++ b/third_party/cgit/filters/html-converters/rst2html @@ -0,0 +1,2 @@ +#!/bin/bash +exec rst2html.py --template <(echo -e "%(stylesheet)s\n%(body_pre_docinfo)s\n%(docinfo)s\n%(body)s") diff --git a/third_party/cgit/filters/html-converters/txt2html b/third_party/cgit/filters/html-converters/txt2html new file mode 100755 index 0000000000..495eeceb27 --- /dev/null +++ b/third_party/cgit/filters/html-converters/txt2html @@ -0,0 +1,4 @@ +#!/bin/sh +echo "<pre>" +sed "s|&|\\&|g;s|'|\\'|g;s|\"|\\"|g;s|<|\\<|g;s|>|\\>|g" +echo "</pre>" diff --git a/third_party/cgit/filters/syntax-highlighting.py b/third_party/cgit/filters/syntax-highlighting.py new file mode 100755 index 0000000000..e912594c48 --- /dev/null +++ b/third_party/cgit/filters/syntax-highlighting.py @@ -0,0 +1,55 @@ +#!/usr/bin/env python3 + +# This script uses Pygments and Python3. You must have both installed +# for this to work. +# +# http://pygments.org/ +# http://python.org/ +# +# It may be used with the source-filter or repo.source-filter settings +# in cgitrc. +# +# The following environment variables can be used to retrieve the +# configuration of the repository for which this script is called: +# CGIT_REPO_URL ( = repo.url setting ) +# CGIT_REPO_NAME ( = repo.name setting ) +# CGIT_REPO_PATH ( = repo.path setting ) +# CGIT_REPO_OWNER ( = repo.owner setting ) +# CGIT_REPO_DEFBRANCH ( = repo.defbranch setting ) +# CGIT_REPO_SECTION ( = section setting ) +# CGIT_REPO_CLONE_URL ( = repo.clone-url setting ) + + +import sys +import io +from pygments import highlight +from pygments.util import ClassNotFound +from pygments.lexers import TextLexer +from pygments.lexers import guess_lexer +from pygments.lexers import guess_lexer_for_filename +from pygments.formatters import HtmlFormatter + + +sys.stdin = io.TextIOWrapper(sys.stdin.buffer, encoding='utf-8', errors='replace') +sys.stdout = io.TextIOWrapper(sys.stdout.buffer, encoding='utf-8', errors='replace') +data = sys.stdin.read() +filename = sys.argv[1] +formatter = HtmlFormatter(style='pastie', nobackground=True) + +try: + lexer = guess_lexer_for_filename(filename, data) +except ClassNotFound: + # check if there is any shebang + if data[0:2] == '#!': + lexer = guess_lexer(data) + else: + lexer = TextLexer() +except TypeError: + lexer = TextLexer() + +# highlight! :-) +# printout pygments' css definitions as well +sys.stdout.write('<style>') +sys.stdout.write(formatter.get_style_defs('.highlight')) +sys.stdout.write('</style>') +sys.stdout.write(highlight(data, lexer, formatter, outfile=None)) diff --git a/third_party/cgit/filters/syntax-highlighting.sh b/third_party/cgit/filters/syntax-highlighting.sh new file mode 100755 index 0000000000..840bc34fff --- /dev/null +++ b/third_party/cgit/filters/syntax-highlighting.sh @@ -0,0 +1,121 @@ +#!/bin/sh +# This script can be used to implement syntax highlighting in the cgit +# tree-view by referring to this file with the source-filter or repo.source- +# filter options in cgitrc. +# +# This script requires a shell supporting the ${var##pattern} syntax. +# It is supported by at least dash and bash, however busybox environments +# might have to use an external call to sed instead. +# +# Note: the highlight command (http://www.andre-simon.de/) uses css for syntax +# highlighting, so you'll probably want something like the following included +# in your css file: +# +# Style definition file generated by highlight 2.4.8, http://www.andre-simon.de/ +# +# table.blob .num { color:#2928ff; } +# table.blob .esc { color:#ff00ff; } +# table.blob .str { color:#ff0000; } +# table.blob .dstr { color:#818100; } +# table.blob .slc { color:#838183; font-style:italic; } +# table.blob .com { color:#838183; font-style:italic; } +# table.blob .dir { color:#008200; } +# table.blob .sym { color:#000000; } +# table.blob .kwa { color:#000000; font-weight:bold; } +# table.blob .kwb { color:#830000; } +# table.blob .kwc { color:#000000; font-weight:bold; } +# table.blob .kwd { color:#010181; } +# +# +# Style definition file generated by highlight 2.6.14, http://www.andre-simon.de/ +# +# body.hl { background-color:#ffffff; } +# pre.hl { color:#000000; background-color:#ffffff; font-size:10pt; font-family:'Courier New';} +# .hl.num { color:#2928ff; } +# .hl.esc { color:#ff00ff; } +# .hl.str { color:#ff0000; } +# .hl.dstr { color:#818100; } +# .hl.slc { color:#838183; font-style:italic; } +# .hl.com { color:#838183; font-style:italic; } +# .hl.dir { color:#008200; } +# .hl.sym { color:#000000; } +# .hl.line { color:#555555; } +# .hl.mark { background-color:#ffffbb;} +# .hl.kwa { color:#000000; font-weight:bold; } +# .hl.kwb { color:#830000; } +# .hl.kwc { color:#000000; font-weight:bold; } +# .hl.kwd { color:#010181; } +# +# +# Style definition file generated by highlight 3.8, http://www.andre-simon.de/ +# +# body.hl { background-color:#e0eaee; } +# pre.hl { color:#000000; background-color:#e0eaee; font-size:10pt; font-family:'Courier New';} +# .hl.num { color:#b07e00; } +# .hl.esc { color:#ff00ff; } +# .hl.str { color:#bf0303; } +# .hl.pps { color:#818100; } +# .hl.slc { color:#838183; font-style:italic; } +# .hl.com { color:#838183; font-style:italic; } +# .hl.ppc { color:#008200; } +# .hl.opt { color:#000000; } +# .hl.lin { color:#555555; } +# .hl.kwa { color:#000000; font-weight:bold; } +# .hl.kwb { color:#0057ae; } +# .hl.kwc { color:#000000; font-weight:bold; } +# .hl.kwd { color:#010181; } +# +# +# Style definition file generated by highlight 3.13, http://www.andre-simon.de/ +# +# body.hl { background-color:#e0eaee; } +# pre.hl { color:#000000; background-color:#e0eaee; font-size:10pt; font-family:'Courier New',monospace;} +# .hl.num { color:#b07e00; } +# .hl.esc { color:#ff00ff; } +# .hl.str { color:#bf0303; } +# .hl.pps { color:#818100; } +# .hl.slc { color:#838183; font-style:italic; } +# .hl.com { color:#838183; font-style:italic; } +# .hl.ppc { color:#008200; } +# .hl.opt { color:#000000; } +# .hl.ipl { color:#0057ae; } +# .hl.lin { color:#555555; } +# .hl.kwa { color:#000000; font-weight:bold; } +# .hl.kwb { color:#0057ae; } +# .hl.kwc { color:#000000; font-weight:bold; } +# .hl.kwd { color:#010181; } +# +# +# The following environment variables can be used to retrieve the configuration +# of the repository for which this script is called: +# CGIT_REPO_URL ( = repo.url setting ) +# CGIT_REPO_NAME ( = repo.name setting ) +# CGIT_REPO_PATH ( = repo.path setting ) +# CGIT_REPO_OWNER ( = repo.owner setting ) +# CGIT_REPO_DEFBRANCH ( = repo.defbranch setting ) +# CGIT_REPO_SECTION ( = section setting ) +# CGIT_REPO_CLONE_URL ( = repo.clone-url setting ) +# + +# store filename and extension in local vars +BASENAME="$1" +EXTENSION="${BASENAME##*.}" + +[ "${BASENAME}" = "${EXTENSION}" ] && EXTENSION=txt +[ -z "${EXTENSION}" ] && EXTENSION=txt + +# map Makefile and Makefile.* to .mk +[ "${BASENAME%%.*}" = "Makefile" ] && EXTENSION=mk + +# highlight versions 2 and 3 have different commandline options. Specifically, +# the -X option that is used for version 2 is replaced by the -O xhtml option +# for version 3. +# +# Version 2 can be found (for example) on EPEL 5, while version 3 can be +# found (for example) on EPEL 6. +# +# This is for version 2 +exec highlight --force -f -I -X -S "$EXTENSION" 2>/dev/null + +# This is for version 3 +#exec highlight --force -f -I -O xhtml -S "$EXTENSION" 2>/dev/null diff --git a/third_party/cgit/gen-version.sh b/third_party/cgit/gen-version.sh new file mode 100755 index 0000000000..80cf49af48 --- /dev/null +++ b/third_party/cgit/gen-version.sh @@ -0,0 +1,20 @@ +#!/bin/sh + +# Get version-info specified in Makefile +V=$1 + +# Use `git describe` to get current version if we're inside a git repo +if test "$(git rev-parse --git-dir 2>/dev/null)" = '.git' +then + V=$(git describe --abbrev=4 HEAD 2>/dev/null) +fi + +new="CGIT_VERSION = $V" +old=$(cat VERSION 2>/dev/null) + +# Exit if VERSION is uptodate +test "$old" = "$new" && exit 0 + +# Update VERSION with new version-info +echo "$new" > VERSION +cat VERSION diff --git a/third_party/cgit/html.c b/third_party/cgit/html.c new file mode 100644 index 0000000000..ced781adc6 --- /dev/null +++ b/third_party/cgit/html.c @@ -0,0 +1,344 @@ +/* html.c: helper functions for html output + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "html.h" +#include "url.h" + +/* Percent-encoding of each character, except: a-zA-Z0-9!$()*,./:;@- */ +static const char* url_escape_table[256] = { + "%00", "%01", "%02", "%03", "%04", "%05", "%06", "%07", + "%08", "%09", "%0a", "%0b", "%0c", "%0d", "%0e", "%0f", + "%10", "%11", "%12", "%13", "%14", "%15", "%16", "%17", + "%18", "%19", "%1a", "%1b", "%1c", "%1d", "%1e", "%1f", + "%20", NULL, "%22", "%23", NULL, "%25", "%26", "%27", + NULL, NULL, NULL, "%2b", NULL, NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, NULL, "%3c", "%3d", "%3e", "%3f", + NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, NULL, "%5c", NULL, "%5e", NULL, + "%60", NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, "%7b", "%7c", "%7d", NULL, "%7f", + "%80", "%81", "%82", "%83", "%84", "%85", "%86", "%87", + "%88", "%89", "%8a", "%8b", "%8c", "%8d", "%8e", "%8f", + "%90", "%91", "%92", "%93", "%94", "%95", "%96", "%97", + "%98", "%99", "%9a", "%9b", "%9c", "%9d", "%9e", "%9f", + "%a0", "%a1", "%a2", "%a3", "%a4", "%a5", "%a6", "%a7", + "%a8", "%a9", "%aa", "%ab", "%ac", "%ad", "%ae", "%af", + "%b0", "%b1", "%b2", "%b3", "%b4", "%b5", "%b6", "%b7", + "%b8", "%b9", "%ba", "%bb", "%bc", "%bd", "%be", "%bf", + "%c0", "%c1", "%c2", "%c3", "%c4", "%c5", "%c6", "%c7", + "%c8", "%c9", "%ca", "%cb", "%cc", "%cd", "%ce", "%cf", + "%d0", "%d1", "%d2", "%d3", "%d4", "%d5", "%d6", "%d7", + "%d8", "%d9", "%da", "%db", "%dc", "%dd", "%de", "%df", + "%e0", "%e1", "%e2", "%e3", "%e4", "%e5", "%e6", "%e7", + "%e8", "%e9", "%ea", "%eb", "%ec", "%ed", "%ee", "%ef", + "%f0", "%f1", "%f2", "%f3", "%f4", "%f5", "%f6", "%f7", + "%f8", "%f9", "%fa", "%fb", "%fc", "%fd", "%fe", "%ff" +}; + +char *fmt(const char *format, ...) +{ + static char buf[8][1024]; + static int bufidx; + int len; + va_list args; + + bufidx++; + bufidx &= 7; + + va_start(args, format); + len = vsnprintf(buf[bufidx], sizeof(buf[bufidx]), format, args); + va_end(args); + if (len >= sizeof(buf[bufidx])) { + fprintf(stderr, "[html.c] string truncated: %s\n", format); + exit(1); + } + return buf[bufidx]; +} + +char *fmtalloc(const char *format, ...) +{ + struct strbuf sb = STRBUF_INIT; + va_list args; + + va_start(args, format); + strbuf_vaddf(&sb, format, args); + va_end(args); + + return strbuf_detach(&sb, NULL); +} + +void html_raw(const char *data, size_t size) +{ + if (fwrite(data, 1, size, stdout) != size) + die_errno("write error on html output"); +} + +void html(const char *txt) +{ + html_raw(txt, strlen(txt)); +} + +void htmlf(const char *format, ...) +{ + va_list args; + struct strbuf buf = STRBUF_INIT; + + va_start(args, format); + strbuf_vaddf(&buf, format, args); + va_end(args); + html(buf.buf); + strbuf_release(&buf); +} + +void html_txtf(const char *format, ...) +{ + va_list args; + + va_start(args, format); + html_vtxtf(format, args); + va_end(args); +} + +void html_vtxtf(const char *format, va_list ap) +{ + va_list cp; + struct strbuf buf = STRBUF_INIT; + + va_copy(cp, ap); + strbuf_vaddf(&buf, format, cp); + va_end(cp); + html_txt(buf.buf); + strbuf_release(&buf); +} + +void html_txt(const char *txt) +{ + if (txt) + html_ntxt(txt, strlen(txt)); +} + +ssize_t html_ntxt(const char *txt, size_t len) +{ + const char *t = txt; + ssize_t slen; + + if (len > SSIZE_MAX) + return -1; + + slen = (ssize_t) len; + while (t && *t && slen--) { + int c = *t; + if (c == '<' || c == '>' || c == '&') { + html_raw(txt, t - txt); + if (c == '>') + html(">"); + else if (c == '<') + html("<"); + else if (c == '&') + html("&"); + txt = t + 1; + } + t++; + } + if (t != txt) + html_raw(txt, t - txt); + return slen; +} + +void html_attrf(const char *fmt, ...) +{ + va_list ap; + struct strbuf sb = STRBUF_INIT; + + va_start(ap, fmt); + strbuf_vaddf(&sb, fmt, ap); + va_end(ap); + + html_attr(sb.buf); + strbuf_release(&sb); +} + +void html_attr(const char *txt) +{ + const char *t = txt; + while (t && *t) { + int c = *t; + if (c == '<' || c == '>' || c == '\'' || c == '\"' || c == '&') { + html_raw(txt, t - txt); + if (c == '>') + html(">"); + else if (c == '<') + html("<"); + else if (c == '\'') + html("'"); + else if (c == '"') + html("""); + else if (c == '&') + html("&"); + txt = t + 1; + } + t++; + } + if (t != txt) + html(txt); +} + +void html_url_path(const char *txt) +{ + const char *t = txt; + while (t && *t) { + unsigned char c = *t; + const char *e = url_escape_table[c]; + if (e && c != '+' && c != '&') { + html_raw(txt, t - txt); + html(e); + txt = t + 1; + } + t++; + } + if (t != txt) + html(txt); +} + +void html_url_arg(const char *txt) +{ + const char *t = txt; + while (t && *t) { + unsigned char c = *t; + const char *e = url_escape_table[c]; + if (c == ' ') + e = "+"; + if (e) { + html_raw(txt, t - txt); + html(e); + txt = t + 1; + } + t++; + } + if (t != txt) + html(txt); +} + +void html_header_arg_in_quotes(const char *txt) +{ + const char *t = txt; + while (t && *t) { + unsigned char c = *t; + const char *e = NULL; + if (c == '\\') + e = "\\\\"; + else if (c == '\r') + e = "\\r"; + else if (c == '\n') + e = "\\n"; + else if (c == '"') + e = "\\\""; + if (e) { + html_raw(txt, t - txt); + html(e); + txt = t + 1; + } + t++; + } + if (t != txt) + html(txt); + +} + +void html_hidden(const char *name, const char *value) +{ + html("<input type='hidden' name='"); + html_attr(name); + html("' value='"); + html_attr(value); + html("'/>"); +} + +void html_option(const char *value, const char *text, const char *selected_value) +{ + html("<option value='"); + html_attr(value); + html("'"); + if (selected_value && !strcmp(selected_value, value)) + html(" selected='selected'"); + html(">"); + html_txt(text); + html("</option>\n"); +} + +void html_intoption(int value, const char *text, int selected_value) +{ + htmlf("<option value='%d'%s>", value, + value == selected_value ? " selected='selected'" : ""); + html_txt(text); + html("</option>"); +} + +void html_link_open(const char *url, const char *title, const char *class) +{ + html("<a href='"); + html_attr(url); + if (title) { + html("' title='"); + html_attr(title); + } + if (class) { + html("' class='"); + html_attr(class); + } + html("'>"); +} + +void html_link_close(void) +{ + html("</a>"); +} + +void html_fileperm(unsigned short mode) +{ + htmlf("%c%c%c", (mode & 4 ? 'r' : '-'), + (mode & 2 ? 'w' : '-'), (mode & 1 ? 'x' : '-')); +} + +int html_include(const char *filename) +{ + FILE *f; + char buf[4096]; + size_t len; + + if (!(f = fopen(filename, "r"))) { + fprintf(stderr, "[cgit] Failed to include file %s: %s (%d).\n", + filename, strerror(errno), errno); + return -1; + } + while ((len = fread(buf, 1, 4096, f)) > 0) + html_raw(buf, len); + fclose(f); + return 0; +} + +void http_parse_querystring(const char *txt, void (*fn)(const char *name, const char *value)) +{ + const char *t = txt; + + while (t && *t) { + char *name = url_decode_parameter_name(&t); + if (*name) { + char *value = url_decode_parameter_value(&t); + fn(name, value); + free(value); + } + free(name); + } +} diff --git a/third_party/cgit/html.h b/third_party/cgit/html.h new file mode 100644 index 0000000000..fa4de77587 --- /dev/null +++ b/third_party/cgit/html.h @@ -0,0 +1,37 @@ +#ifndef HTML_H +#define HTML_H + +#include "cgit.h" + +extern void html_raw(const char *txt, size_t size); +extern void html(const char *txt); + +__attribute__((format (printf,1,2))) +extern void htmlf(const char *format,...); + +__attribute__((format (printf,1,2))) +extern void html_txtf(const char *format,...); + +__attribute__((format (printf,1,0))) +extern void html_vtxtf(const char *format, va_list ap); + +__attribute__((format (printf,1,2))) +extern void html_attrf(const char *format,...); + +extern void html_txt(const char *txt); +extern ssize_t html_ntxt(const char *txt, size_t len); +extern void html_attr(const char *txt); +extern void html_url_path(const char *txt); +extern void html_url_arg(const char *txt); +extern void html_header_arg_in_quotes(const char *txt); +extern void html_hidden(const char *name, const char *value); +extern void html_option(const char *value, const char *text, const char *selected_value); +extern void html_intoption(int value, const char *text, int selected_value); +extern void html_link_open(const char *url, const char *title, const char *class); +extern void html_link_close(void); +extern void html_fileperm(unsigned short mode); +extern int html_include(const char *filename); + +extern void http_parse_querystring(const char *txt, void (*fn)(const char *name, const char *value)); + +#endif /* HTML_H */ diff --git a/third_party/cgit/parsing.c b/third_party/cgit/parsing.c new file mode 100644 index 0000000000..83d3521e89 --- /dev/null +++ b/third_party/cgit/parsing.c @@ -0,0 +1,223 @@ +/* parsing.c: parsing of config files + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" + +/* + * url syntax: [repo ['/' cmd [ '/' path]]] + * repo: any valid repo url, may contain '/' + * cmd: log | commit | diff | tree | view | blob | snapshot + * path: any valid path, may contain '/' + * + */ +void cgit_parse_url(const char *url) +{ + char *c, *cmd, *p; + struct cgit_repo *repo; + + if (!url || url[0] == '\0') + return; + + ctx.qry.page = NULL; + ctx.repo = cgit_get_repoinfo(url); + if (ctx.repo) { + ctx.qry.repo = ctx.repo->url; + return; + } + + cmd = NULL; + c = strchr(url, '/'); + while (c) { + c[0] = '\0'; + repo = cgit_get_repoinfo(url); + if (repo) { + ctx.repo = repo; + cmd = c; + } + c[0] = '/'; + c = strchr(c + 1, '/'); + } + + if (ctx.repo) { + ctx.qry.repo = ctx.repo->url; + p = strchr(cmd + 1, '/'); + if (p) { + p[0] = '\0'; + if (p[1]) + ctx.qry.path = trim_end(p + 1, '/'); + } + if (cmd[1]) + ctx.qry.page = xstrdup(cmd + 1); + } +} + +static char *substr(const char *head, const char *tail) +{ + char *buf; + + if (tail < head) + return xstrdup(""); + buf = xmalloc(tail - head + 1); + strlcpy(buf, head, tail - head + 1); + return buf; +} + +static void parse_user(const char *t, char **name, char **email, unsigned long *date, int *tz) +{ + struct ident_split ident; + unsigned email_len; + + if (!split_ident_line(&ident, t, (uintptr_t)strchrnul(t, '\n') - (uintptr_t)t)) { + *name = substr(ident.name_begin, ident.name_end); + + email_len = ident.mail_end - ident.mail_begin; + *email = xmalloc(strlen("<") + email_len + strlen(">") + 1); + xsnprintf(*email, email_len + 3, "<%.*s>", email_len, ident.mail_begin); + + if (ident.date_begin) + *date = strtoul(ident.date_begin, NULL, 10); + if (ident.tz_begin) + *tz = atoi(ident.tz_begin); + } +} + +#ifdef NO_ICONV +#define reencode(a, b, c) +#else +static const char *reencode(char **txt, const char *src_enc, const char *dst_enc) +{ + char *tmp; + + if (!txt) + return NULL; + + if (!*txt || !src_enc || !dst_enc) + return *txt; + + /* no encoding needed if src_enc equals dst_enc */ + if (!strcasecmp(src_enc, dst_enc)) + return *txt; + + tmp = reencode_string(*txt, dst_enc, src_enc); + if (tmp) { + free(*txt); + *txt = tmp; + } + return *txt; +} +#endif + +static const char *next_header_line(const char *p) +{ + p = strchr(p, '\n'); + if (!p) + return NULL; + return p + 1; +} + +static int end_of_header(const char *p) +{ + return !p || (*p == '\n'); +} + +struct commitinfo *cgit_parse_commit(struct commit *commit) +{ + struct commitinfo *ret; + const char *p = repo_get_commit_buffer(the_repository, commit, NULL); + const char *t; + + ret = xcalloc(1, sizeof(struct commitinfo)); + ret->commit = commit; + + if (!p) + return ret; + + if (!skip_prefix(p, "tree ", &p)) + die("Bad commit: %s", oid_to_hex(&commit->object.oid)); + p += the_hash_algo->hexsz + 1; + + while (skip_prefix(p, "parent ", &p)) + p += the_hash_algo->hexsz + 1; + + if (p && skip_prefix(p, "author ", &p)) { + parse_user(p, &ret->author, &ret->author_email, + &ret->author_date, &ret->author_tz); + p = next_header_line(p); + } + + if (p && skip_prefix(p, "committer ", &p)) { + parse_user(p, &ret->committer, &ret->committer_email, + &ret->committer_date, &ret->committer_tz); + p = next_header_line(p); + } + + if (p && skip_prefix(p, "encoding ", &p)) { + t = strchr(p, '\n'); + if (t) { + ret->msg_encoding = substr(p, t + 1); + p = t + 1; + } + } + + if (!ret->msg_encoding) + ret->msg_encoding = xstrdup("UTF-8"); + + while (!end_of_header(p)) + p = next_header_line(p); + while (p && *p == '\n') + p++; + if (!p) + return ret; + + t = strchrnul(p, '\n'); + ret->subject = substr(p, t); + while (*t == '\n') + t++; + ret->msg = xstrdup(t); + + reencode(&ret->author, ret->msg_encoding, PAGE_ENCODING); + reencode(&ret->author_email, ret->msg_encoding, PAGE_ENCODING); + reencode(&ret->committer, ret->msg_encoding, PAGE_ENCODING); + reencode(&ret->committer_email, ret->msg_encoding, PAGE_ENCODING); + reencode(&ret->subject, ret->msg_encoding, PAGE_ENCODING); + reencode(&ret->msg, ret->msg_encoding, PAGE_ENCODING); + + return ret; +} + +struct taginfo *cgit_parse_tag(struct tag *tag) +{ + void *data; + enum object_type type; + unsigned long size; + const char *p; + struct taginfo *ret = NULL; + + data = repo_read_object_file(the_repository, &tag->object.oid, &type, &size); + if (!data || type != OBJ_TAG) + goto cleanup; + + ret = xcalloc(1, sizeof(struct taginfo)); + + for (p = data; !end_of_header(p); p = next_header_line(p)) { + if (skip_prefix(p, "tagger ", &p)) { + parse_user(p, &ret->tagger, &ret->tagger_email, + &ret->tagger_date, &ret->tagger_tz); + } + } + + while (p && *p == '\n') + p++; + + if (p && *p) + ret->msg = xstrdup(p); + +cleanup: + free(data); + return ret; +} diff --git a/third_party/cgit/robots.txt b/third_party/cgit/robots.txt new file mode 100644 index 0000000000..1b33266d53 --- /dev/null +++ b/third_party/cgit/robots.txt @@ -0,0 +1,4 @@ +User-agent: * +Disallow: /*/snapshot/* +Disallow: /*/blame/* +Allow: / diff --git a/third_party/cgit/scan-tree.c b/third_party/cgit/scan-tree.c new file mode 100644 index 0000000000..aa93665426 --- /dev/null +++ b/third_party/cgit/scan-tree.c @@ -0,0 +1,268 @@ +/* scan-tree.c + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "scan-tree.h" +#include "configfile.h" +#include "html.h" +#include <config.h> + +/* return 1 if path contains a objects/ directory and a HEAD file */ +static int is_git_dir(const char *path) +{ + struct stat st; + struct strbuf pathbuf = STRBUF_INIT; + int result = 0; + + strbuf_addf(&pathbuf, "%s/objects", path); + if (stat(pathbuf.buf, &st)) { + if (errno != ENOENT) + fprintf(stderr, "Error checking path %s: %s (%d)\n", + path, strerror(errno), errno); + goto out; + } + if (!S_ISDIR(st.st_mode)) + goto out; + + strbuf_reset(&pathbuf); + strbuf_addf(&pathbuf, "%s/HEAD", path); + if (stat(pathbuf.buf, &st)) { + if (errno != ENOENT) + fprintf(stderr, "Error checking path %s: %s (%d)\n", + path, strerror(errno), errno); + goto out; + } + if (!S_ISREG(st.st_mode)) + goto out; + + result = 1; +out: + strbuf_release(&pathbuf); + return result; +} + +static struct cgit_repo *repo; +static repo_config_fn config_fn; + +static void scan_tree_repo_config(const char *name, const char *value) +{ + config_fn(repo, name, value); +} + +static int gitconfig_config(const char *key, const char *value, const struct config_context *, void *cb) +{ + const char *name; + + if (!strcmp(key, "gitweb.owner")) + config_fn(repo, "owner", value); + else if (!strcmp(key, "gitweb.description")) + config_fn(repo, "desc", value); + else if (!strcmp(key, "gitweb.category")) + config_fn(repo, "section", value); + else if (!strcmp(key, "gitweb.homepage")) + config_fn(repo, "homepage", value); + else if (skip_prefix(key, "cgit.", &name)) + config_fn(repo, name, value); + + return 0; +} + +static char *xstrrchr(char *s, char *from, int c) +{ + while (from >= s && *from != c) + from--; + return from < s ? NULL : from; +} + +static void add_repo(const char *base, struct strbuf *path, repo_config_fn fn) +{ + struct stat st; + struct passwd *pwd; + size_t pathlen; + struct strbuf rel = STRBUF_INIT; + char *p, *slash; + int n; + size_t size; + + if (stat(path->buf, &st)) { + fprintf(stderr, "Error accessing %s: %s (%d)\n", + path->buf, strerror(errno), errno); + return; + } + + strbuf_addch(path, '/'); + pathlen = path->len; + + if (ctx.cfg.strict_export) { + strbuf_addstr(path, ctx.cfg.strict_export); + if(stat(path->buf, &st)) + return; + strbuf_setlen(path, pathlen); + } + + strbuf_addstr(path, "noweb"); + if (!stat(path->buf, &st)) + return; + strbuf_setlen(path, pathlen); + + if (!starts_with(path->buf, base)) + strbuf_addbuf(&rel, path); + else + strbuf_addstr(&rel, path->buf + strlen(base) + 1); + + if (!strcmp(rel.buf + rel.len - 5, "/.git")) + strbuf_setlen(&rel, rel.len - 5); + else if (rel.len && rel.buf[rel.len - 1] == '/') + strbuf_setlen(&rel, rel.len - 1); + + repo = cgit_add_repo(rel.buf); + config_fn = fn; + if (ctx.cfg.enable_git_config) { + strbuf_addstr(path, "config"); + git_config_from_file(gitconfig_config, path->buf, NULL); + strbuf_setlen(path, pathlen); + } + + if (ctx.cfg.remove_suffix) { + size_t urllen; + strip_suffix(repo->url, ".git", &urllen); + strip_suffix_mem(repo->url, &urllen, "/"); + repo->url[urllen] = '\0'; + } + repo->path = xstrdup(path->buf); + while (!repo->owner) { + if ((pwd = getpwuid(st.st_uid)) == NULL) { + break; + } + if (pwd->pw_gecos) + if ((p = strchr(pwd->pw_gecos, ','))) + *p = '\0'; + repo->owner = xstrdup(pwd->pw_gecos ? pwd->pw_gecos : pwd->pw_name); + } + + if (repo->desc == cgit_default_repo_desc || !repo->desc) { + strbuf_addstr(path, "description"); + if (!stat(path->buf, &st)) + readfile(path->buf, &repo->desc, &size); + strbuf_setlen(path, pathlen); + } + + if (ctx.cfg.section_from_path) { + n = ctx.cfg.section_from_path; + if (n > 0) { + slash = rel.buf - 1; + while (slash && n && (slash = strchr(slash + 1, '/'))) + n--; + } else { + slash = rel.buf + rel.len; + while (slash && n && (slash = xstrrchr(rel.buf, slash - 1, '/'))) + n++; + } + if (slash && !n) { + *slash = '\0'; + repo->section = xstrdup(rel.buf); + *slash = '/'; + if (starts_with(repo->name, repo->section)) { + repo->name += strlen(repo->section); + if (*repo->name == '/') + repo->name++; + } + } + } + + strbuf_addstr(path, "cgitrc"); + if (!stat(path->buf, &st)) + parse_configfile(path->buf, &scan_tree_repo_config); + + strbuf_release(&rel); +} + +static void scan_path(const char *base, const char *path, repo_config_fn fn) +{ + DIR *dir = opendir(path); + struct dirent *ent; + struct strbuf pathbuf = STRBUF_INIT; + size_t pathlen = strlen(path); + struct stat st; + + if (!dir) { + fprintf(stderr, "Error opening directory %s: %s (%d)\n", + path, strerror(errno), errno); + return; + } + + strbuf_add(&pathbuf, path, strlen(path)); + if (is_git_dir(pathbuf.buf)) { + add_repo(base, &pathbuf, fn); + goto end; + } + strbuf_addstr(&pathbuf, "/.git"); + if (is_git_dir(pathbuf.buf)) { + add_repo(base, &pathbuf, fn); + goto end; + } + /* + * Add one because we don't want to lose the trailing '/' when we + * reset the length of pathbuf in the loop below. + */ + pathlen++; + while ((ent = readdir(dir)) != NULL) { + if (ent->d_name[0] == '.') { + if (ent->d_name[1] == '\0') + continue; + if (ent->d_name[1] == '.' && ent->d_name[2] == '\0') + continue; + if (!ctx.cfg.scan_hidden_path) + continue; + } + strbuf_setlen(&pathbuf, pathlen); + strbuf_addstr(&pathbuf, ent->d_name); + if (stat(pathbuf.buf, &st)) { + fprintf(stderr, "Error checking path %s: %s (%d)\n", + pathbuf.buf, strerror(errno), errno); + continue; + } + if (S_ISDIR(st.st_mode)) + scan_path(base, pathbuf.buf, fn); + } +end: + strbuf_release(&pathbuf); + closedir(dir); +} + +void scan_projects(const char *path, const char *projectsfile, repo_config_fn fn) +{ + struct strbuf line = STRBUF_INIT; + FILE *projects; + int err; + + projects = fopen(projectsfile, "r"); + if (!projects) { + fprintf(stderr, "Error opening projectsfile %s: %s (%d)\n", + projectsfile, strerror(errno), errno); + return; + } + while (strbuf_getline(&line, projects) != EOF) { + if (!line.len) + continue; + strbuf_insert(&line, 0, "/", 1); + strbuf_insert(&line, 0, path, strlen(path)); + scan_path(path, line.buf, fn); + } + if ((err = ferror(projects))) { + fprintf(stderr, "Error reading from projectsfile %s: %s (%d)\n", + projectsfile, strerror(err), err); + } + fclose(projects); + strbuf_release(&line); +} + +void scan_tree(const char *path, repo_config_fn fn) +{ + scan_path(path, path, fn); +} diff --git a/third_party/cgit/scan-tree.h b/third_party/cgit/scan-tree.h new file mode 100644 index 0000000000..1afbd4bbcd --- /dev/null +++ b/third_party/cgit/scan-tree.h @@ -0,0 +1,2 @@ +extern void scan_projects(const char *path, const char *projectsfile, repo_config_fn fn); +extern void scan_tree(const char *path, repo_config_fn fn); diff --git a/third_party/cgit/shared.c b/third_party/cgit/shared.c new file mode 100644 index 0000000000..26b6ddb329 --- /dev/null +++ b/third_party/cgit/shared.c @@ -0,0 +1,582 @@ +/* shared.c: global vars + some callback functions + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" + +struct cgit_repolist cgit_repolist; +struct cgit_context ctx; + +int chk_zero(int result, char *msg) +{ + if (result != 0) + die_errno("%s", msg); + return result; +} + +int chk_positive(int result, char *msg) +{ + if (result <= 0) + die_errno("%s", msg); + return result; +} + +int chk_non_negative(int result, char *msg) +{ + if (result < 0) + die_errno("%s", msg); + return result; +} + +char *cgit_default_repo_desc = "[no description]"; +struct cgit_repo *cgit_add_repo(const char *url) +{ + struct cgit_repo *ret; + + if (++cgit_repolist.count > cgit_repolist.length) { + if (cgit_repolist.length == 0) + cgit_repolist.length = 8; + else + cgit_repolist.length *= 2; + cgit_repolist.repos = xrealloc(cgit_repolist.repos, + cgit_repolist.length * + sizeof(struct cgit_repo)); + } + + ret = &cgit_repolist.repos[cgit_repolist.count-1]; + memset(ret, 0, sizeof(struct cgit_repo)); + ret->url = trim_end(url, '/'); + ret->name = ret->url; + ret->path = NULL; + ret->desc = cgit_default_repo_desc; + ret->extra_head_content = NULL; + ret->owner = NULL; + ret->homepage = NULL; + ret->section = ctx.cfg.section; + ret->snapshots = ctx.cfg.snapshots; + ret->enable_blame = ctx.cfg.enable_blame; + ret->enable_commit_graph = ctx.cfg.enable_commit_graph; + ret->enable_log_filecount = ctx.cfg.enable_log_filecount; + ret->enable_log_linecount = ctx.cfg.enable_log_linecount; + ret->enable_remote_branches = ctx.cfg.enable_remote_branches; + ret->enable_subject_links = ctx.cfg.enable_subject_links; + ret->enable_html_serving = ctx.cfg.enable_html_serving; + ret->max_stats = ctx.cfg.max_stats; + ret->branch_sort = ctx.cfg.branch_sort; + ret->commit_sort = ctx.cfg.commit_sort; + ret->module_link = ctx.cfg.module_link; + ret->readme = ctx.cfg.readme; + ret->mtime = -1; + ret->about_filter = ctx.cfg.about_filter; + ret->commit_filter = ctx.cfg.commit_filter; + ret->source_filter = ctx.cfg.source_filter; + ret->email_filter = ctx.cfg.email_filter; + ret->owner_filter = ctx.cfg.owner_filter; + ret->clone_url = ctx.cfg.clone_url; + ret->submodules.strdup_strings = 1; + ret->hide = ret->ignore = 0; + return ret; +} + +struct cgit_repo *cgit_get_repoinfo(const char *url) +{ + int i; + struct cgit_repo *repo; + + for (i = 0; i < cgit_repolist.count; i++) { + repo = &cgit_repolist.repos[i]; + if (repo->ignore) + continue; + if (!strcmp(repo->url, url)) + return repo; + } + return NULL; +} + +void cgit_free_commitinfo(struct commitinfo *info) +{ + free(info->author); + free(info->author_email); + free(info->committer); + free(info->committer_email); + free(info->subject); + free(info->msg); + free(info->msg_encoding); + free(info); +} + +char *trim_end(const char *str, char c) +{ + int len; + + if (str == NULL) + return NULL; + len = strlen(str); + while (len > 0 && str[len - 1] == c) + len--; + if (len == 0) + return NULL; + return xstrndup(str, len); +} + +char *ensure_end(const char *str, char c) +{ + size_t len = strlen(str); + char *result; + + if (len && str[len - 1] == c) + return xstrndup(str, len); + + result = xmalloc(len + 2); + memcpy(result, str, len); + result[len] = '/'; + result[len + 1] = '\0'; + return result; +} + +void strbuf_ensure_end(struct strbuf *sb, char c) +{ + if (!sb->len || sb->buf[sb->len - 1] != c) + strbuf_addch(sb, c); +} + +void cgit_add_ref(struct reflist *list, struct refinfo *ref) +{ + size_t size; + + if (list->count >= list->alloc) { + list->alloc += (list->alloc ? list->alloc : 4); + size = list->alloc * sizeof(struct refinfo *); + list->refs = xrealloc(list->refs, size); + } + list->refs[list->count++] = ref; +} + +static struct refinfo *cgit_mk_refinfo(const char *refname, const struct object_id *oid) +{ + struct refinfo *ref; + + ref = xmalloc(sizeof (struct refinfo)); + ref->refname = xstrdup(refname); + ref->object = parse_object(the_repository, oid); + switch (ref->object->type) { + case OBJ_TAG: + ref->tag = cgit_parse_tag((struct tag *)ref->object); + break; + case OBJ_COMMIT: + ref->commit = cgit_parse_commit((struct commit *)ref->object); + break; + } + return ref; +} + +void cgit_free_taginfo(struct taginfo *tag) +{ + if (tag->tagger) + free(tag->tagger); + if (tag->tagger_email) + free(tag->tagger_email); + if (tag->msg) + free(tag->msg); + free(tag); +} + +static void cgit_free_refinfo(struct refinfo *ref) +{ + if (ref->refname) + free((char *)ref->refname); + switch (ref->object->type) { + case OBJ_TAG: + cgit_free_taginfo(ref->tag); + break; + case OBJ_COMMIT: + cgit_free_commitinfo(ref->commit); + break; + } + free(ref); +} + +void cgit_free_reflist_inner(struct reflist *list) +{ + int i; + + for (i = 0; i < list->count; i++) { + cgit_free_refinfo(list->refs[i]); + } + free(list->refs); +} + +int cgit_refs_cb(const char *refname, const struct object_id *oid, int flags, + void *cb_data) +{ + struct reflist *list = (struct reflist *)cb_data; + struct refinfo *info = cgit_mk_refinfo(refname, oid); + + if (info) + cgit_add_ref(list, info); + return 0; +} + +void cgit_diff_tree_cb(struct diff_queue_struct *q, + struct diff_options *options, void *data) +{ + int i; + + for (i = 0; i < q->nr; i++) { + if (q->queue[i]->status == 'U') + continue; + ((filepair_fn)data)(q->queue[i]); + } +} + +static int load_mmfile(mmfile_t *file, const struct object_id *oid) +{ + enum object_type type; + + if (is_null_oid(oid)) { + file->ptr = (char *)""; + file->size = 0; + } else { + file->ptr = repo_read_object_file(the_repository, oid, &type, + (unsigned long *)&file->size); + } + return 1; +} + +/* + * Receive diff-buffers from xdiff and concatenate them as + * needed across multiple callbacks. + * + * This is basically a copy of xdiff-interface.c/xdiff_outf(), + * ripped from git and modified to use globals instead of + * a special callback-struct. + */ +static char *diffbuf = NULL; +static int buflen = 0; + +static int filediff_cb(void *priv, mmbuffer_t *mb, int nbuf) +{ + int i; + + for (i = 0; i < nbuf; i++) { + if (mb[i].ptr[mb[i].size-1] != '\n') { + /* Incomplete line */ + diffbuf = xrealloc(diffbuf, buflen + mb[i].size); + memcpy(diffbuf + buflen, mb[i].ptr, mb[i].size); + buflen += mb[i].size; + continue; + } + + /* we have a complete line */ + if (!diffbuf) { + ((linediff_fn)priv)(mb[i].ptr, mb[i].size); + continue; + } + diffbuf = xrealloc(diffbuf, buflen + mb[i].size); + memcpy(diffbuf + buflen, mb[i].ptr, mb[i].size); + ((linediff_fn)priv)(diffbuf, buflen + mb[i].size); + free(diffbuf); + diffbuf = NULL; + buflen = 0; + } + if (diffbuf) { + ((linediff_fn)priv)(diffbuf, buflen); + free(diffbuf); + diffbuf = NULL; + buflen = 0; + } + return 0; +} + +int cgit_diff_files(const struct object_id *old_oid, + const struct object_id *new_oid, unsigned long *old_size, + unsigned long *new_size, int *binary, int context, + int ignorews, linediff_fn fn) +{ + mmfile_t file1, file2; + xpparam_t diff_params; + xdemitconf_t emit_params; + xdemitcb_t emit_cb; + + if (!load_mmfile(&file1, old_oid) || !load_mmfile(&file2, new_oid)) + return 1; + + *old_size = file1.size; + *new_size = file2.size; + + if ((file1.ptr && buffer_is_binary(file1.ptr, file1.size)) || + (file2.ptr && buffer_is_binary(file2.ptr, file2.size))) { + *binary = 1; + if (file1.size) + free(file1.ptr); + if (file2.size) + free(file2.ptr); + return 0; + } + + memset(&diff_params, 0, sizeof(diff_params)); + memset(&emit_params, 0, sizeof(emit_params)); + memset(&emit_cb, 0, sizeof(emit_cb)); + diff_params.flags = XDF_NEED_MINIMAL; + if (ignorews) + diff_params.flags |= XDF_IGNORE_WHITESPACE; + emit_params.ctxlen = context > 0 ? context : 3; + emit_params.flags = XDL_EMIT_FUNCNAMES; + emit_cb.out_line = filediff_cb; + emit_cb.priv = fn; + xdl_diff(&file1, &file2, &diff_params, &emit_params, &emit_cb); + if (file1.size) + free(file1.ptr); + if (file2.size) + free(file2.ptr); + return 0; +} + +void cgit_diff_tree(const struct object_id *old_oid, + const struct object_id *new_oid, + filepair_fn fn, const char *prefix, int ignorews) +{ + struct diff_options opt; + struct pathspec_item *item; + + repo_diff_setup(the_repository, &opt); + opt.output_format = DIFF_FORMAT_CALLBACK; + opt.detect_rename = 1; + opt.rename_limit = ctx.cfg.renamelimit; + opt.flags.recursive = 1; + if (ignorews) + DIFF_XDL_SET(&opt, IGNORE_WHITESPACE); + opt.format_callback = cgit_diff_tree_cb; + opt.format_callback_data = fn; + if (prefix) { + item = xcalloc(1, sizeof(*item)); + item->match = xstrdup(prefix); + item->len = strlen(prefix); + opt.pathspec.nr = 1; + opt.pathspec.items = item; + } + diff_setup_done(&opt); + + if (old_oid && !is_null_oid(old_oid)) + diff_tree_oid(old_oid, new_oid, "", &opt); + else + diff_root_tree_oid(new_oid, "", &opt); + diffcore_std(&opt); + diff_flush(&opt); +} + +void cgit_diff_commit(struct commit *commit, filepair_fn fn, const char *prefix) +{ + const struct object_id *old_oid = NULL; + + if (commit->parents) + old_oid = &commit->parents->item->object.oid; + cgit_diff_tree(old_oid, &commit->object.oid, fn, prefix, + ctx.qry.ignorews); +} + +int cgit_parse_snapshots_mask(const char *str) +{ + struct string_list tokens = STRING_LIST_INIT_DUP; + struct string_list_item *item; + const struct cgit_snapshot_format *f; + int rv = 0; + + /* favor legacy setting */ + if (atoi(str)) + return 1; + + if (strcmp(str, "all") == 0) + return INT_MAX; + + string_list_split(&tokens, str, ' ', -1); + string_list_remove_empty_items(&tokens, 0); + + for_each_string_list_item(item, &tokens) { + for (f = cgit_snapshot_formats; f->suffix; f++) { + if (!strcmp(item->string, f->suffix) || + !strcmp(item->string, f->suffix + 1)) { + rv |= cgit_snapshot_format_bit(f); + break; + } + } + } + + string_list_clear(&tokens, 0); + return rv; +} + +typedef struct { + char * name; + char * value; +} cgit_env_var; + +void cgit_prepare_repo_env(struct cgit_repo * repo) +{ + cgit_env_var env_vars[] = { + { .name = "CGIT_REPO_URL", .value = repo->url }, + { .name = "CGIT_REPO_NAME", .value = repo->name }, + { .name = "CGIT_REPO_PATH", .value = repo->path }, + { .name = "CGIT_REPO_OWNER", .value = repo->owner }, + { .name = "CGIT_REPO_DEFBRANCH", .value = repo->defbranch }, + { .name = "CGIT_REPO_SECTION", .value = repo->section }, + { .name = "CGIT_REPO_CLONE_URL", .value = repo->clone_url } + }; + int env_var_count = ARRAY_SIZE(env_vars); + cgit_env_var *p, *q; + static char *warn = "cgit warning: failed to set env: %s=%s\n"; + + p = env_vars; + q = p + env_var_count; + for (; p < q; p++) + if (p->value && setenv(p->name, p->value, 1)) + fprintf(stderr, warn, p->name, p->value); +} + +/* Read the content of the specified file into a newly allocated buffer, + * zeroterminate the buffer and return 0 on success, errno otherwise. + */ +int readfile(const char *path, char **buf, size_t *size) +{ + int fd, e; + struct stat st; + + fd = open(path, O_RDONLY); + if (fd == -1) + return errno; + if (fstat(fd, &st)) { + e = errno; + close(fd); + return e; + } + if (!S_ISREG(st.st_mode)) { + close(fd); + return EISDIR; + } + *buf = xmalloc(st.st_size + 1); + *size = read_in_full(fd, *buf, st.st_size); + e = errno; + (*buf)[*size] = '\0'; + close(fd); + return (*size == st.st_size ? 0 : e); +} + +static int is_token_char(char c) +{ + return isalnum(c) || c == '_'; +} + +/* Replace name with getenv(name), return pointer to zero-terminating char + */ +static char *expand_macro(char *name, int maxlength) +{ + char *value; + size_t len; + + len = 0; + value = getenv(name); + if (value) { + len = strlen(value) + 1; + if (len > maxlength) + len = maxlength; + strlcpy(name, value, len); + --len; + } + return name + len; +} + +#define EXPBUFSIZE (1024 * 8) + +/* Replace all tokens prefixed by '$' in the specified text with the + * value of the named environment variable. + * NB: the return value is a static buffer, i.e. it must be strdup'd + * by the caller. + */ +char *expand_macros(const char *txt) +{ + static char result[EXPBUFSIZE]; + char *p, *start; + int len; + + p = result; + start = NULL; + while (p < result + EXPBUFSIZE - 1 && txt && *txt) { + *p = *txt; + if (start) { + if (!is_token_char(*txt)) { + if (p - start > 0) { + *p = '\0'; + len = result + EXPBUFSIZE - start - 1; + p = expand_macro(start, len) - 1; + } + start = NULL; + txt--; + } + p++; + txt++; + continue; + } + if (*txt == '$') { + start = p; + txt++; + continue; + } + p++; + txt++; + } + *p = '\0'; + if (start && p - start > 0) { + len = result + EXPBUFSIZE - start - 1; + p = expand_macro(start, len); + *p = '\0'; + } + return result; +} + +char *get_mimetype_for_filename(const char *filename) +{ + char *ext, *mimetype, line[1024]; + struct string_list list = STRING_LIST_INIT_NODUP; + int i; + FILE *file; + struct string_list_item *mime; + + if (!filename) + return NULL; + + ext = strrchr(filename, '.'); + if (!ext) + return NULL; + ++ext; + if (!ext[0]) + return NULL; + mime = string_list_lookup(&ctx.cfg.mimetypes, ext); + if (mime) + return xstrdup(mime->util); + + if (!ctx.cfg.mimetype_file) + return NULL; + file = fopen(ctx.cfg.mimetype_file, "r"); + if (!file) + return NULL; + while (fgets(line, sizeof(line), file)) { + if (!line[0] || line[0] == '#') + continue; + string_list_split_in_place(&list, line, " \t\r\n", -1); + string_list_remove_empty_items(&list, 0); + mimetype = list.items[0].string; + for (i = 1; i < list.nr; i++) { + if (!strcasecmp(ext, list.items[i].string)) { + fclose(file); + return xstrdup(mimetype); + } + } + string_list_clear(&list, 0); + } + fclose(file); + return NULL; +} diff --git a/third_party/cgit/tests/.gitignore b/third_party/cgit/tests/.gitignore new file mode 100644 index 0000000000..3fd2e965c8 --- /dev/null +++ b/third_party/cgit/tests/.gitignore @@ -0,0 +1,2 @@ +trash\ directory.t* +test-results diff --git a/third_party/cgit/tests/Makefile b/third_party/cgit/tests/Makefile new file mode 100644 index 0000000000..65e1117338 --- /dev/null +++ b/third_party/cgit/tests/Makefile @@ -0,0 +1,17 @@ +include ../git/config.mak.uname +-include ../cgit.conf + +SHELL_PATH ?= $(SHELL) +SHELL_PATH_SQ = $(subst ','\'',$(SHELL_PATH)) + +T = $(wildcard t[0-9][0-9][0-9][0-9]-*.sh) + +all: $(T) + +$(T): + @'$(SHELL_PATH_SQ)' $@ $(CGIT_TEST_OPTS) + +clean: + $(RM) -rf trash + +.PHONY: $(T) clean diff --git a/third_party/cgit/tests/filters/dump.sh b/third_party/cgit/tests/filters/dump.sh new file mode 100755 index 0000000000..da6f7a1b18 --- /dev/null +++ b/third_party/cgit/tests/filters/dump.sh @@ -0,0 +1,4 @@ +#!/bin/sh + +[ "$#" -gt 0 ] && printf "%s " "$*" +tr '[:lower:]' '[:upper:]' diff --git a/third_party/cgit/tests/setup.sh b/third_party/cgit/tests/setup.sh new file mode 100755 index 0000000000..31e7d5bb27 --- /dev/null +++ b/third_party/cgit/tests/setup.sh @@ -0,0 +1,161 @@ +# This file should be sourced by all test-scripts +# +# Main functions: +# prepare_tests(description) - setup for testing, i.e. create repos+config +# run_test(description, script) - run one test, i.e. eval script +# +# Helper functions +# cgit_query(querystring) - call cgit with the specified querystring +# cgit_url(url) - call cgit with the specified virtual url +# +# Example script: +# +# . setup.sh +# prepare_tests "html validation" +# run_test 'repo index' 'cgit_url "/" | tidy -e' +# run_test 'repo summary' 'cgit_url "/foo" | tidy -e' + +# We don't want to run Git commands through Valgrind, so we filter out the +# --valgrind option here and handle it ourselves. We copy the arguments +# assuming that none contain a newline, although other whitespace is +# preserved. +LF=' +' +test_argv= + +while test $# != 0 +do + case "$1" in + --va|--val|--valg|--valgr|--valgri|--valgrin|--valgrind) + cgit_valgrind=t + test_argv="$test_argv${LF}--verbose" + ;; + *) + test_argv="$test_argv$LF$1" + ;; + esac + shift +done + +OLDIFS=$IFS +IFS=$LF +set -- $test_argv +IFS=$OLDIFS + +: ${TEST_DIRECTORY=$(pwd)/../git/t} +: ${TEST_OUTPUT_DIRECTORY=$(pwd)} +TEST_NO_CREATE_REPO=YesPlease +. "$TEST_DIRECTORY"/test-lib.sh + +# Prepend the directory containing cgit to PATH. +if test -n "$cgit_valgrind" +then + GIT_VALGRIND="$TEST_DIRECTORY/valgrind" + CGIT_VALGRIND=$(cd ../valgrind && pwd) + PATH="$CGIT_VALGRIND/bin:$PATH" + export GIT_VALGRIND CGIT_VALGRIND +else + PATH="$(pwd)/../..:$PATH" +fi + +FILTER_DIRECTORY=$(cd ../filters && pwd) + +mkrepo() { + name=$1 + count=$2 + test_create_repo "$name" + ( + cd "$name" + n=1 + while test $n -le $count + do + echo $n >file-$n + git add file-$n + git commit -m "commit $n" + n=$(expr $n + 1) + done + case "$3" in + testplus) + echo "hello" >a+b + git add a+b + git commit -m "add a+b" + git branch "1+2" + ;; + commit-graph) + git commit-graph write + ;; + esac + ) +} + +setup_repos() +{ + rm -rf cache + mkdir -p cache + mkrepo repos/foo 5 >/dev/null + mkrepo repos/bar 50 commit-graph >/dev/null + mkrepo repos/foo+bar 10 testplus >/dev/null + mkrepo "repos/with space" 2 >/dev/null + mkrepo repos/filter 5 testplus >/dev/null + cat >cgitrc <<EOF +virtual-root=/ +cache-root=$PWD/cache + +cache-size=1021 +snapshots=tar.gz tar.bz tar.lz tar.xz tar.zst zip +enable-log-filecount=1 +enable-log-linecount=1 +summary-log=5 +summary-branches=5 +summary-tags=5 +clone-url=git://example.org/\$CGIT_REPO_URL.git +enable-filter-overrides=1 + +repo.url=foo +repo.path=$PWD/repos/foo/.git +# Do not specify a description for this repo, as it then will be assigned +# the constant value "[no description]" (which actually used to cause a +# segfault). + +repo.url=bar +repo.path=$PWD/repos/bar/.git +repo.desc=the bar repo + +repo.url=foo+bar +repo.path=$PWD/repos/foo+bar/.git +repo.desc=the foo+bar repo + +repo.url=with space +repo.path=$PWD/repos/with space/.git +repo.desc=spaced repo + +repo.url=filter-exec +repo.path=$PWD/repos/filter/.git +repo.desc=filtered repo +repo.about-filter=exec:$FILTER_DIRECTORY/dump.sh +repo.commit-filter=exec:$FILTER_DIRECTORY/dump.sh +repo.email-filter=exec:$FILTER_DIRECTORY/dump.sh +repo.source-filter=exec:$FILTER_DIRECTORY/dump.sh +repo.readme=master:a+b +EOF +} + +cgit_query() +{ + CGIT_CONFIG="$PWD/cgitrc" QUERY_STRING="$1" cgit +} + +cgit_url() +{ + CGIT_CONFIG="$PWD/cgitrc" QUERY_STRING="url=$1" cgit +} + +strip_headers() { + while read -r line + do + test -z "$line" && break + done + cat +} + +test -z "$CGIT_TEST_NO_CREATE_REPOS" && setup_repos diff --git a/third_party/cgit/tests/t0001-validate-git-versions.sh b/third_party/cgit/tests/t0001-validate-git-versions.sh new file mode 100755 index 0000000000..dd84fe3fcb --- /dev/null +++ b/third_party/cgit/tests/t0001-validate-git-versions.sh @@ -0,0 +1,45 @@ +#!/bin/sh + +if [ "${CGIT_TEST_NO_GIT_VERSION}" = "YesPlease" ]; then + exit 0 +fi + +test_description='Check Git version is correct' +CGIT_TEST_NO_CREATE_REPOS=YesPlease +. ./setup.sh + +test_expect_success 'extract Git version from Makefile' ' + sed -n -e "/^GIT_VER[ ]*=/ { + s/^GIT_VER[ ]*=[ ]*// + p + }" ../../Makefile >makefile_version +' + +# Note that Git's GIT-VERSION-GEN script applies "s/-/./g" to the version +# string to produce the internal version in the GIT-VERSION-FILE, so we +# must apply the same transformation to the version in the Makefile before +# comparing them. +test_expect_success 'test Git version matches Makefile' ' + ( cat ../../git/GIT-VERSION-FILE || echo "No GIT-VERSION-FILE" ) | + sed -e "s/GIT_VERSION[ ]*=[ ]*//" -e "s/\\.dirty$//" >git_version && + sed -e "s/-/./g" makefile_version >makefile_git_version && + test_cmp git_version makefile_git_version +' + +test_expect_success 'test submodule version matches Makefile' ' + if ! test -e ../../git/.git + then + echo "git/ is not a Git repository" >&2 + else + ( + cd ../.. && + sm_oid=$(git ls-files --stage -- git | + sed -e "s/^[0-9]* \\([0-9a-f]*\\) [0-9] .*$/\\1/") && + cd git && + git describe --match "v[0-9]*" $sm_oid + ) | sed -e "s/^v//" -e "s/-/./" >sm_version && + test_cmp sm_version makefile_version + fi +' + +test_done diff --git a/third_party/cgit/tests/t0010-validate-html.sh b/third_party/cgit/tests/t0010-validate-html.sh new file mode 100755 index 0000000000..ca08d69d14 --- /dev/null +++ b/third_party/cgit/tests/t0010-validate-html.sh @@ -0,0 +1,40 @@ +#!/bin/sh + +test_description='Validate html with tidy' +. ./setup.sh + + +test_url() +{ + tidy_opt="-eq" + test -z "$NO_TIDY_WARNINGS" || tidy_opt+=" --show-warnings no" + cgit_url "$1" >tidy-$test_count.tmp || return + sed -e "1,4d" tidy-$test_count.tmp >tidy-$test_count || return + "$tidy" $tidy_opt tidy-$test_count + rc=$? + + # tidy returns with exitcode 1 on warnings, 2 on error + if test $rc = 2 + then + false + else + : + fi +} + +tidy=`which tidy 2>/dev/null` +test -n "$tidy" || { + skip_all='Skipping html validation tests: tidy not found' + test_done + exit +} + +test_expect_success 'index page' 'test_url ""' +test_expect_success 'foo' 'test_url "foo"' +test_expect_success 'foo/log' 'test_url "foo/log"' +test_expect_success 'foo/tree' 'test_url "foo/tree"' +test_expect_success 'foo/tree/file-1' 'test_url "foo/tree/file-1"' +test_expect_success 'foo/commit' 'test_url "foo/commit"' +test_expect_success 'foo/diff' 'test_url "foo/diff"' + +test_done diff --git a/third_party/cgit/tests/t0020-validate-cache.sh b/third_party/cgit/tests/t0020-validate-cache.sh new file mode 100755 index 0000000000..657765d897 --- /dev/null +++ b/third_party/cgit/tests/t0020-validate-cache.sh @@ -0,0 +1,78 @@ +#!/bin/sh + +test_description='Validate cache' +. ./setup.sh + +test_expect_success 'verify cache-size=0' ' + + rm -f cache/* && + sed -e "s/cache-size=1021$/cache-size=0/" cgitrc >cgitrc.tmp && + mv -f cgitrc.tmp cgitrc && + cgit_url "" && + cgit_url "foo" && + cgit_url "foo/refs" && + cgit_url "foo/tree" && + cgit_url "foo/log" && + cgit_url "foo/diff" && + cgit_url "foo/patch" && + cgit_url "bar" && + cgit_url "bar/refs" && + cgit_url "bar/tree" && + cgit_url "bar/log" && + cgit_url "bar/diff" && + cgit_url "bar/patch" && + ls cache >output && + test_line_count = 0 output +' + +test_expect_success 'verify cache-size=1' ' + + rm -f cache/* && + sed -e "s/cache-size=0$/cache-size=1/" cgitrc >cgitrc.tmp && + mv -f cgitrc.tmp cgitrc && + cgit_url "" && + cgit_url "foo" && + cgit_url "foo/refs" && + cgit_url "foo/tree" && + cgit_url "foo/log" && + cgit_url "foo/diff" && + cgit_url "foo/patch" && + cgit_url "bar" && + cgit_url "bar/refs" && + cgit_url "bar/tree" && + cgit_url "bar/log" && + cgit_url "bar/diff" && + cgit_url "bar/patch" && + ls cache >output && + test_line_count = 1 output +' + +test_expect_success 'verify cache-size=1021' ' + + rm -f cache/* && + sed -e "s/cache-size=1$/cache-size=1021/" cgitrc >cgitrc.tmp && + mv -f cgitrc.tmp cgitrc && + cgit_url "" && + cgit_url "foo" && + cgit_url "foo/refs" && + cgit_url "foo/tree" && + cgit_url "foo/log" && + cgit_url "foo/diff" && + cgit_url "foo/patch" && + cgit_url "bar" && + cgit_url "bar/refs" && + cgit_url "bar/tree" && + cgit_url "bar/log" && + cgit_url "bar/diff" && + cgit_url "bar/patch" && + ls cache >output && + test_line_count = 13 output && + cgit_url "foo/ls_cache" >output.full && + strip_headers <output.full >output && + test_line_count = 13 output && + # Check that ls_cache output is cached correctly + cgit_url "foo/ls_cache" >output.second && + test_cmp output.full output.second +' + +test_done diff --git a/third_party/cgit/tests/t0101-index.sh b/third_party/cgit/tests/t0101-index.sh new file mode 100755 index 0000000000..82ef9b04e5 --- /dev/null +++ b/third_party/cgit/tests/t0101-index.sh @@ -0,0 +1,17 @@ +#!/bin/sh + +test_description='Check content on index page' +. ./setup.sh + +test_expect_success 'generate index page' 'cgit_url "" >tmp' +test_expect_success 'find foo repo' 'grep "foo" tmp' +test_expect_success 'find foo description' 'grep "\[no description\]" tmp' +test_expect_success 'find bar repo' 'grep "bar" tmp' +test_expect_success 'find bar description' 'grep "the bar repo" tmp' +test_expect_success 'find foo+bar repo' 'grep ">foo+bar<" tmp' +test_expect_success 'verify foo+bar link' 'grep "/foo+bar/" tmp' +test_expect_success 'verify "with%20space" link' 'grep "/with%20space/" tmp' +test_expect_success 'no tree-link' '! grep "foo/tree" tmp' +test_expect_success 'no log-link' '! grep "foo/log" tmp' + +test_done diff --git a/third_party/cgit/tests/t0102-summary.sh b/third_party/cgit/tests/t0102-summary.sh new file mode 100755 index 0000000000..b8864cb187 --- /dev/null +++ b/third_party/cgit/tests/t0102-summary.sh @@ -0,0 +1,25 @@ +#!/bin/sh + +test_description='Check content on summary page' +. ./setup.sh + +test_expect_success 'generate foo summary' 'cgit_url "foo" >tmp' +test_expect_success 'find commit 1' 'grep "commit 1" tmp' +test_expect_success 'find commit 5' 'grep "commit 5" tmp' +test_expect_success 'find branch master' 'grep "master" tmp' +test_expect_success 'no tags' '! grep "tags" tmp' +test_expect_success 'clone-url expanded correctly' ' + grep "git://example.org/foo.git" tmp +' + +test_expect_success 'generate bar summary' 'cgit_url "bar" >tmp' +test_expect_success 'no commit 45' '! grep "commit 45" tmp' +test_expect_success 'find commit 46' 'grep "commit 46" tmp' +test_expect_success 'find commit 50' 'grep "commit 50" tmp' +test_expect_success 'find branch master' 'grep "master" tmp' +test_expect_success 'no tags' '! grep "tags" tmp' +test_expect_success 'clone-url expanded correctly' ' + grep "git://example.org/bar.git" tmp +' + +test_done diff --git a/third_party/cgit/tests/t0103-log.sh b/third_party/cgit/tests/t0103-log.sh new file mode 100755 index 0000000000..bdf1435a16 --- /dev/null +++ b/third_party/cgit/tests/t0103-log.sh @@ -0,0 +1,24 @@ +#!/bin/sh + +test_description='Check content on log page' +. ./setup.sh + +test_expect_success 'generate foo/log' 'cgit_url "foo/log" >tmp' +test_expect_success 'find commit 1' 'grep "commit 1" tmp' +test_expect_success 'find commit 5' 'grep "commit 5" tmp' + +test_expect_success 'generate bar/log' 'cgit_url "bar/log" >tmp' +test_expect_success 'find commit 1' 'grep "commit 1" tmp' +test_expect_success 'find commit 50' 'grep "commit 50" tmp' + +test_expect_success 'generate "with%20space/log?qt=grep&q=commit+1"' ' + cgit_url "with+space/log&qt=grep&q=commit+1" >tmp +' +test_expect_success 'find commit 1' 'grep "commit 1" tmp' +test_expect_success 'find link with %20 in path' 'grep "/with%20space/log/?qt=grep" tmp' +test_expect_success 'find link with + in arg' 'grep "/log/?qt=grep&q=commit+1" tmp' +test_expect_success 'no links with space in path' '! grep "href=./with space/" tmp' +test_expect_success 'no links with space in arg' '! grep "q=commit 1" tmp' +test_expect_success 'commit 2 is not visible' '! grep "commit 2" tmp' + +test_done diff --git a/third_party/cgit/tests/t0104-tree.sh b/third_party/cgit/tests/t0104-tree.sh new file mode 100755 index 0000000000..2e140f5939 --- /dev/null +++ b/third_party/cgit/tests/t0104-tree.sh @@ -0,0 +1,32 @@ +#!/bin/sh + +test_description='Check content on tree page' +. ./setup.sh + +test_expect_success 'generate bar/tree' 'cgit_url "bar/tree" >tmp' +test_expect_success 'find file-1' 'grep "file-1" tmp' +test_expect_success 'find file-50' 'grep "file-50" tmp' + +test_expect_success 'generate bar/tree/file-50' 'cgit_url "bar/tree/file-50" >tmp' + +test_expect_success 'find line 1' ' + grep "<a id=.n1. href=.#n1.>1</a>" tmp +' + +test_expect_success 'no line 2' ' + ! grep "<a id=.n2. href=.#n2.>2</a>" tmp +' + +test_expect_success 'generate foo+bar/tree' 'cgit_url "foo%2bbar/tree" >tmp' + +test_expect_success 'verify a+b link' ' + grep "/foo+bar/tree/a+b" tmp +' + +test_expect_success 'generate foo+bar/tree?h=1+2' 'cgit_url "foo%2bbar/tree&h=1%2b2" >tmp' + +test_expect_success 'verify a+b?h=1+2 link' ' + grep "/foo+bar/tree/a+b?h=1%2b2" tmp +' + +test_done diff --git a/third_party/cgit/tests/t0105-commit.sh b/third_party/cgit/tests/t0105-commit.sh new file mode 100755 index 0000000000..cfed1e7d69 --- /dev/null +++ b/third_party/cgit/tests/t0105-commit.sh @@ -0,0 +1,36 @@ +#!/bin/sh + +test_description='Check content on commit page' +. ./setup.sh + +test_expect_success 'generate foo/commit' 'cgit_url "foo/commit" >tmp' +test_expect_success 'find tree link' 'grep "<a href=./foo/tree/.>" tmp' +test_expect_success 'find parent link' 'grep -E "<a href=./foo/commit/\?id=.+>" tmp' + +test_expect_success 'find commit subject' ' + grep "<div class=.commit-subject.>commit 5<" tmp +' + +test_expect_success 'find commit msg' 'grep "<pre class=.commit-msg.></pre>" tmp' +test_expect_success 'find diffstat' 'grep "<table summary=.diffstat. class=.diffstat.>" tmp' + +test_expect_success 'find diff summary' ' + grep "1 files changed, 1 insertions, 0 deletions" tmp +' + +test_expect_success 'get root commit' ' + root=$(cd repos/foo && git rev-list --reverse HEAD | head -1) && + cgit_url "foo/commit&id=$root" >tmp && + grep "</html>" tmp +' + +test_expect_success 'root commit contains diffstat' ' + grep "<a href=./foo/diff/file-1.id=[0-9a-f]\{40,64\}.>file-1</a>" tmp +' + +test_expect_success 'root commit contains diff' ' + grep ">diff --git a/file-1 b/file-1" tmp && + grep "<span class=.add.>+1</span>" tmp +' + +test_done diff --git a/third_party/cgit/tests/t0106-diff.sh b/third_party/cgit/tests/t0106-diff.sh new file mode 100755 index 0000000000..62a0a74a64 --- /dev/null +++ b/third_party/cgit/tests/t0106-diff.sh @@ -0,0 +1,19 @@ +#!/bin/sh + +test_description='Check content on diff page' +. ./setup.sh + +test_expect_success 'generate foo/diff' 'cgit_url "foo/diff" >tmp' +test_expect_success 'find diff header' 'grep "a/file-5 b/file-5" tmp' +test_expect_success 'find blob link' 'grep "<a href=./foo/tree/file-5?id=" tmp' +test_expect_success 'find added file' 'grep "new file mode 100644" tmp' + +test_expect_success 'find hunk header' ' + grep "<span class=.hunk.>@@ -0,0 +1 @@</span>" tmp +' + +test_expect_success 'find added line' ' + grep "<span class=.add.>+5</span>" tmp +' + +test_done diff --git a/third_party/cgit/tests/t0107-snapshot.sh b/third_party/cgit/tests/t0107-snapshot.sh new file mode 100755 index 0000000000..0811ec4074 --- /dev/null +++ b/third_party/cgit/tests/t0107-snapshot.sh @@ -0,0 +1,205 @@ +#!/bin/sh + +test_description='Verify snapshot' +. ./setup.sh + +test_expect_success 'get foo/snapshot/master.tar.gz' ' + cgit_url "foo/snapshot/master.tar.gz" >tmp +' + +test_expect_success 'check html headers' ' + head -n 1 tmp | + grep "Content-Type: application/x-gzip" && + + head -n 2 tmp | + grep "Content-Disposition: inline; filename=.master.tar.gz." +' + +test_expect_success 'strip off the header lines' ' + strip_headers <tmp >master.tar.gz +' + +test_expect_success 'verify gzip format' ' + gunzip --test master.tar.gz +' + +test_expect_success 'untar' ' + rm -rf master && + gzip -dc master.tar.gz | tar -xf - +' + +test_expect_success 'count files' ' + ls master/ >output && + test_line_count = 5 output +' + +test_expect_success 'verify untarred file-5' ' + grep "^5$" master/file-5 && + test_line_count = 1 master/file-5 +' + +if test -n "$(which lzip 2>/dev/null)"; then + test_set_prereq LZIP +else + say 'Skipping LZIP validation tests: lzip not found' +fi + +test_expect_success LZIP 'get foo/snapshot/master.tar.lz' ' + cgit_url "foo/snapshot/master.tar.lz" >tmp +' + +test_expect_success LZIP 'check html headers' ' + head -n 1 tmp | + grep "Content-Type: application/x-lzip" && + + head -n 2 tmp | + grep "Content-Disposition: inline; filename=.master.tar.lz." +' + +test_expect_success LZIP 'strip off the header lines' ' + strip_headers <tmp >master.tar.lz +' + +test_expect_success LZIP 'verify lzip format' ' + lzip --test master.tar.lz +' + +test_expect_success LZIP 'untar' ' + rm -rf master && + lzip -dc master.tar.lz | tar -xf - +' + +test_expect_success LZIP 'count files' ' + ls master/ >output && + test_line_count = 5 output +' + +test_expect_success LZIP 'verify untarred file-5' ' + grep "^5$" master/file-5 && + test_line_count = 1 master/file-5 +' + +if test -n "$(which xz 2>/dev/null)"; then + test_set_prereq XZ +else + say 'Skipping XZ validation tests: xz not found' +fi + +test_expect_success XZ 'get foo/snapshot/master.tar.xz' ' + cgit_url "foo/snapshot/master.tar.xz" >tmp +' + +test_expect_success XZ 'check html headers' ' + head -n 1 tmp | + grep "Content-Type: application/x-xz" && + + head -n 2 tmp | + grep "Content-Disposition: inline; filename=.master.tar.xz." +' + +test_expect_success XZ 'strip off the header lines' ' + strip_headers <tmp >master.tar.xz +' + +test_expect_success XZ 'verify xz format' ' + xz --test master.tar.xz +' + +test_expect_success XZ 'untar' ' + rm -rf master && + xz -dc master.tar.xz | tar -xf - +' + +test_expect_success XZ 'count files' ' + ls master/ >output && + test_line_count = 5 output +' + +test_expect_success XZ 'verify untarred file-5' ' + grep "^5$" master/file-5 && + test_line_count = 1 master/file-5 +' + +if test -n "$(which zstd 2>/dev/null)"; then + test_set_prereq ZSTD +else + say 'Skipping ZSTD validation tests: zstd not found' +fi + +test_expect_success ZSTD 'get foo/snapshot/master.tar.zst' ' + cgit_url "foo/snapshot/master.tar.zst" >tmp +' + +test_expect_success ZSTD 'check html headers' ' + head -n 1 tmp | + grep "Content-Type: application/x-zstd" && + + head -n 2 tmp | + grep "Content-Disposition: inline; filename=.master.tar.zst." +' + +test_expect_success ZSTD 'strip off the header lines' ' + strip_headers <tmp >master.tar.zst +' + +test_expect_success ZSTD 'verify zstd format' ' + zstd --test master.tar.zst +' + +test_expect_success ZSTD 'untar' ' + rm -rf master && + zstd -dc master.tar.zst | tar -xf - +' + +test_expect_success ZSTD 'count files' ' + ls master/ >output && + test_line_count = 5 output +' + +test_expect_success ZSTD 'verify untarred file-5' ' + grep "^5$" master/file-5 && + test_line_count = 1 master/file-5 +' + +test_expect_success 'get foo/snapshot/master.zip' ' + cgit_url "foo/snapshot/master.zip" >tmp +' + +test_expect_success 'check HTML headers (zip)' ' + head -n 1 tmp | + grep "Content-Type: application/x-zip" && + + head -n 2 tmp | + grep "Content-Disposition: inline; filename=.master.zip." +' + +test_expect_success 'strip off the header lines (zip)' ' + strip_headers <tmp >master.zip +' + +if test -n "$(which unzip 2>/dev/null)"; then + test_set_prereq UNZIP +else + say 'Skipping ZIP validation tests: unzip not found' +fi + +test_expect_success UNZIP 'verify zip format' ' + unzip -t master.zip +' + +test_expect_success UNZIP 'unzip' ' + rm -rf master && + unzip master.zip +' + +test_expect_success UNZIP 'count files (zip)' ' + ls master/ >output && + test_line_count = 5 output +' + +test_expect_success UNZIP 'verify unzipped file-5' ' + grep "^5$" master/file-5 && + test_line_count = 1 master/file-5 +' + +test_done diff --git a/third_party/cgit/tests/t0108-patch.sh b/third_party/cgit/tests/t0108-patch.sh new file mode 100755 index 0000000000..013d68024d --- /dev/null +++ b/third_party/cgit/tests/t0108-patch.sh @@ -0,0 +1,62 @@ +#!/bin/sh + +test_description='Check content on patch page' +. ./setup.sh + +test_expect_success 'generate foo/patch' ' + cgit_query "url=foo/patch" >tmp +' + +test_expect_success 'find `From:` line' ' + grep "^From: " tmp +' + +test_expect_success 'find `Date:` line' ' + grep "^Date: " tmp +' + +test_expect_success 'find `Subject:` line' ' + grep "^Subject: commit 5" tmp +' + +test_expect_success 'find `cgit` signature' ' + tail -2 tmp | head -1 | grep "^cgit" +' + +test_expect_success 'compare with output of git-format-patch(1)' ' + CGIT_VERSION=$(sed -n "s/CGIT_VERSION = //p" ../../VERSION) && + git --git-dir="$PWD/repos/foo/.git" format-patch --subject-prefix="" --signature="cgit $CGIT_VERSION" --stdout HEAD^ >tmp2 && + strip_headers <tmp >tmp_ && + test_cmp tmp_ tmp2 +' + +test_expect_success 'find initial commit' ' + root=$(git --git-dir="$PWD/repos/foo/.git" rev-list --max-parents=0 HEAD) +' + +test_expect_success 'generate patch for initial commit' ' + cgit_query "url=foo/patch&id=$root" >tmp +' + +test_expect_success 'find `cgit` signature' ' + tail -2 tmp | head -1 | grep "^cgit" +' + +test_expect_success 'generate patches for multiple commits' ' + id=$(git --git-dir="$PWD/repos/foo/.git" rev-parse HEAD) && + id2=$(git --git-dir="$PWD/repos/foo/.git" rev-parse HEAD~3) && + cgit_query "url=foo/patch&id=$id&id2=$id2" >tmp +' + +test_expect_success 'find `cgit` signature' ' + tail -2 tmp | head -1 | grep "^cgit" +' + +test_expect_success 'compare with output of git-format-patch(1)' ' + CGIT_VERSION=$(sed -n "s/CGIT_VERSION = //p" ../../VERSION) && + git --git-dir="$PWD/repos/foo/.git" format-patch -N --subject-prefix="" --signature="cgit $CGIT_VERSION" --stdout HEAD~3..HEAD >tmp2 && + strip_headers <tmp >tmp_ && + test_cmp tmp_ tmp2 +' + +test_done diff --git a/third_party/cgit/tests/t0109-gitconfig.sh b/third_party/cgit/tests/t0109-gitconfig.sh new file mode 100755 index 0000000000..189ef28166 --- /dev/null +++ b/third_party/cgit/tests/t0109-gitconfig.sh @@ -0,0 +1,48 @@ +#!/bin/sh + +test_description='Ensure that git does not access $HOME' +. ./setup.sh + +test -n "$(which strace 2>/dev/null)" || { + skip_all='Skipping access validation tests: strace not found' + test_done + exit +} + +strace true 2>/dev/null || { + skip_all='Skipping access validation tests: strace not functional' + test_done + exit +} + +test_no_home_access () { + non_existent_path="/path/to/some/place/that/does/not/possibly/exist" + while test -d "$non_existent_path"; do + non_existent_path="$non_existent_path/$(date +%N)" + done && + strace \ + -E HOME="$non_existent_path" \ + -E CGIT_CONFIG="$PWD/cgitrc" \ + -E QUERY_STRING="url=$1" \ + -e access -f -o strace.out cgit && + ! grep "$non_existent_path" strace.out +} + +test_no_home_access_success() { + test_expect_success "do not access \$HOME: $1" " + test_no_home_access '$1' + " +} + +test_no_home_access_success +test_no_home_access_success foo +test_no_home_access_success foo/refs +test_no_home_access_success foo/log +test_no_home_access_success foo/tree +test_no_home_access_success foo/tree/file-1 +test_no_home_access_success foo/commit +test_no_home_access_success foo/diff +test_no_home_access_success foo/patch +test_no_home_access_success foo/snapshot/master.tar.gz + +test_done diff --git a/third_party/cgit/tests/t0110-rawdiff.sh b/third_party/cgit/tests/t0110-rawdiff.sh new file mode 100755 index 0000000000..66fa7d5d37 --- /dev/null +++ b/third_party/cgit/tests/t0110-rawdiff.sh @@ -0,0 +1,42 @@ +#!/bin/sh + +test_description='Check content on rawdiff page' +. ./setup.sh + +test_expect_success 'generate foo/rawdiff' ' + cgit_query "url=foo/rawdiff" >tmp +' + +test_expect_success 'compare with output of git-diff(1)' ' + git --git-dir="$PWD/repos/foo/.git" diff HEAD^.. >tmp2 && + sed "1,4d" tmp >tmp_ && + cmp tmp_ tmp2 +' + +test_expect_success 'find initial commit' ' + root=$(git --git-dir="$PWD/repos/foo/.git" rev-list --max-parents=0 HEAD) +' + +test_expect_success 'generate diff for initial commit' ' + cgit_query "url=foo/rawdiff&id=$root" >tmp +' + +test_expect_success 'compare with output of git-diff-tree(1)' ' + git --git-dir="$PWD/repos/foo/.git" diff-tree -p --no-commit-id --root "$root" >tmp2 && + sed "1,4d" tmp >tmp_ && + cmp tmp_ tmp2 +' + +test_expect_success 'generate diff for multiple commits' ' + id=$(git --git-dir="$PWD/repos/foo/.git" rev-parse HEAD) && + id2=$(git --git-dir="$PWD/repos/foo/.git" rev-parse HEAD~3) && + cgit_query "url=foo/rawdiff&id=$id&id2=$id2" >tmp +' + +test_expect_success 'compare with output of git-diff(1)' ' + git --git-dir="$PWD/repos/foo/.git" diff HEAD~3..HEAD >tmp2 && + sed "1,4d" tmp >tmp_ && + cmp tmp_ tmp2 +' + +test_done diff --git a/third_party/cgit/tests/t0111-filter.sh b/third_party/cgit/tests/t0111-filter.sh new file mode 100755 index 0000000000..e5d357507c --- /dev/null +++ b/third_party/cgit/tests/t0111-filter.sh @@ -0,0 +1,43 @@ +#!/bin/sh + +test_description='Check filtered content' +. ./setup.sh + +prefixes="exec" + +for prefix in $prefixes +do + test_expect_success "generate filter-$prefix/tree/a%2bb" " + cgit_url 'filter-$prefix/tree/a%2bb' >tmp + " + + test_expect_success "check whether the $prefix source filter works" ' + grep "<code>a+b HELLO$" tmp + ' + + test_expect_success "generate filter-$prefix/about/" " + cgit_url 'filter-$prefix/about/' >tmp + " + + test_expect_success "check whether the $prefix about filter works" ' + grep "<div id='"'"'summary'"'"'>a+b HELLO$" tmp + ' + + test_expect_success "generate filter-$prefix/commit/" " + cgit_url 'filter-$prefix/commit/' >tmp + " + + test_expect_success "check whether the $prefix commit filter works" ' + grep "<div class='"'"'commit-subject'"'"'>ADD A+B" tmp + ' + + test_expect_success "check whether the $prefix email filter works for authors" ' + grep "<author@example.com> commit A U THOR <AUTHOR@EXAMPLE.COM>" tmp + ' + + test_expect_success "check whether the $prefix email filter works for committers" ' + grep "<committer@example.com> commit C O MITTER <COMMITTER@EXAMPLE.COM>" tmp + ' +done + +test_done diff --git a/third_party/cgit/tests/valgrind/bin/cgit b/third_party/cgit/tests/valgrind/bin/cgit new file mode 100755 index 0000000000..dcdfbe5320 --- /dev/null +++ b/third_party/cgit/tests/valgrind/bin/cgit @@ -0,0 +1,12 @@ +#!/bin/sh + +# Note that we currently use Git's suppression file and there are variables +# $GIT_VALGRIND and $CGIT_VALGRIND which point to different places. +exec valgrind -q --error-exitcode=126 \ + --suppressions="$GIT_VALGRIND/default.supp" \ + --gen-suppressions=all \ + --leak-check=no \ + --track-origins=yes \ + --log-fd=4 \ + --input-fd=4 \ + "$CGIT_VALGRIND/../../cgit" "$@" diff --git a/third_party/cgit/tvl-extra.css b/third_party/cgit/tvl-extra.css new file mode 100644 index 0000000000..41f5041d62 --- /dev/null +++ b/third_party/cgit/tvl-extra.css @@ -0,0 +1,35 @@ +/* limit the width of /about/** to help readability */ +.content #summary { + max-width: 800px; +} + +/* highlight cheddar callouts in cgit about views */ +.cheddar-callout { + display: block; + padding: 10px; +} + +.cheddar-question { + color: #3367d6; + background-color: #e8f0fe; +} + +.cheddar-todo { + color: #616161; + background-color: #eeeeee; +} + +.cheddar-tip { + color: #00796b; + background-color: #e0f2f1; +} + +.cheddar-warning { + color: #a52714; + background-color: #fbe9e7; +} + +/* add some padding next to the logo */ +td.logo { + padding-right: 10px; +} diff --git a/third_party/cgit/ui-atom.c b/third_party/cgit/ui-atom.c new file mode 100644 index 0000000000..fefbc79809 --- /dev/null +++ b/third_party/cgit/ui-atom.c @@ -0,0 +1,157 @@ +/* ui-atom.c: functions for atom feeds + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "ui-atom.h" +#include "html.h" +#include "ui-shared.h" + +static void add_entry(struct commit *commit, const char *host) +{ + char delim = '&'; + char *hex; + char *mail, *t, *t2; + struct commitinfo *info; + + info = cgit_parse_commit(commit); + hex = oid_to_hex(&commit->object.oid); + html("<entry>\n"); + html("<title>"); + html_txt(info->subject); + html("</title>\n"); + html("<updated>"); + html_txt(show_date(info->committer_date, 0, + date_mode_from_type(DATE_ISO8601_STRICT))); + html("</updated>\n"); + html("<author>\n"); + if (info->author) { + html("<name>"); + html_txt(info->author); + html("</name>\n"); + } + if (info->author_email && !ctx.cfg.noplainemail) { + mail = xstrdup(info->author_email); + t = strchr(mail, '<'); + if (t) + t++; + else + t = mail; + t2 = strchr(t, '>'); + if (t2) + *t2 = '\0'; + html("<email>"); + html_txt(t); + html("</email>\n"); + free(mail); + } + html("</author>\n"); + html("<published>"); + html_txt(show_date(info->author_date, 0, + date_mode_from_type(DATE_ISO8601_STRICT))); + html("</published>\n"); + if (host) { + char *pageurl; + html("<link rel='alternate' type='text/html' href='"); + html(cgit_httpscheme()); + html_attr(host); + pageurl = cgit_pageurl(ctx.repo->url, "commit", NULL); + html_attr(pageurl); + if (ctx.cfg.virtual_root) + delim = '?'; + html_attrf("%cid=%s", delim, hex); + html("'/>\n"); + free(pageurl); + } + html("<id>"); + html_txtf("urn:%s:%s", the_hash_algo->name, hex); + html("</id>\n"); + html("<content type='text'>\n"); + html_txt(info->msg); + html("</content>\n"); + html("</entry>\n"); + cgit_free_commitinfo(info); +} + + +void cgit_print_atom(char *tip, const char *path, int max_count) +{ + char *host; + const char *argv[] = {NULL, tip, NULL, NULL, NULL}; + struct commit *commit; + struct rev_info rev; + int argc = 2; + int first = 1; + + if (ctx.qry.show_all) + argv[1] = "--all"; + else if (!tip) + argv[1] = ctx.qry.head; + + if (path) { + argv[argc++] = "--"; + argv[argc++] = path; + } + + repo_init_revisions(the_repository, &rev, NULL); + rev.abbrev = DEFAULT_ABBREV; + rev.commit_format = CMIT_FMT_DEFAULT; + rev.verbose_header = 1; + rev.show_root_diff = 0; + rev.max_count = max_count; + setup_revisions(argc, argv, &rev, NULL); + prepare_revision_walk(&rev); + + host = cgit_hosturl(); + ctx.page.mimetype = "text/xml"; + ctx.page.charset = "utf-8"; + cgit_print_http_headers(); + html("<feed xmlns='http://www.w3.org/2005/Atom'>\n"); + html("<title>"); + html_txt(ctx.repo->name); + if (path) { + html("/"); + html_txt(path); + } + if (tip && !ctx.qry.show_all) { + html(", branch "); + html_txt(tip); + } + html("</title>\n"); + html("<subtitle>"); + html_txt(ctx.repo->desc); + html("</subtitle>\n"); + if (host) { + char *fullurl = cgit_currentfullurl(); + char *repourl = cgit_repourl(ctx.repo->url); + html("<id>"); + html_txtf("%s%s%s", cgit_httpscheme(), host, fullurl); + html("</id>\n"); + html("<link rel='self' href='"); + html_attrf("%s%s%s", cgit_httpscheme(), host, fullurl); + html("'/>\n"); + html("<link rel='alternate' type='text/html' href='"); + html_attrf("%s%s%s", cgit_httpscheme(), host, repourl); + html("'/>\n"); + free(fullurl); + free(repourl); + } + while ((commit = get_revision(&rev)) != NULL) { + if (first) { + html("<updated>"); + html_txt(show_date(commit->date, 0, + date_mode_from_type(DATE_ISO8601_STRICT))); + html("</updated>\n"); + first = 0; + } + add_entry(commit, host); + release_commit_memory(the_repository->parsed_objects, commit); + commit->parents = NULL; + } + html("</feed>\n"); + free(host); +} diff --git a/third_party/cgit/ui-atom.h b/third_party/cgit/ui-atom.h new file mode 100644 index 0000000000..dda953bbf4 --- /dev/null +++ b/third_party/cgit/ui-atom.h @@ -0,0 +1,6 @@ +#ifndef UI_ATOM_H +#define UI_ATOM_H + +extern void cgit_print_atom(char *tip, const char *path, int max_count); + +#endif diff --git a/third_party/cgit/ui-blame.c b/third_party/cgit/ui-blame.c new file mode 100644 index 0000000000..6418b24221 --- /dev/null +++ b/third_party/cgit/ui-blame.c @@ -0,0 +1,315 @@ +/* ui-blame.c: functions for blame output + * + * Copyright (C) 2006-2017 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "ui-blame.h" +#include "html.h" +#include "ui-shared.h" +#include "strvec.h" +#include "blame.h" + + +static char *emit_suspect_detail(struct blame_origin *suspect) +{ + struct commitinfo *info; + struct strbuf detail = STRBUF_INIT; + + info = cgit_parse_commit(suspect->commit); + + strbuf_addf(&detail, "author %s", info->author); + if (!ctx.cfg.noplainemail) + strbuf_addf(&detail, " %s", info->author_email); + strbuf_addf(&detail, " %s\n", + show_date(info->author_date, info->author_tz, + cgit_date_mode(DATE_DOTTIME))); + + strbuf_addf(&detail, "committer %s", info->committer); + if (!ctx.cfg.noplainemail) + strbuf_addf(&detail, " %s", info->committer_email); + strbuf_addf(&detail, " %s\n\n", + show_date(info->committer_date, info->committer_tz, + cgit_date_mode(DATE_DOTTIME))); + + strbuf_addstr(&detail, info->subject); + + cgit_free_commitinfo(info); + return strbuf_detach(&detail, NULL); +} + +static void emit_blame_entry_hash(struct blame_entry *ent) +{ + struct blame_origin *suspect = ent->suspect; + struct object_id *oid = &suspect->commit->object.oid; + unsigned long line = 0; + + char *detail = emit_suspect_detail(suspect); + html("<span class='oid'>"); + cgit_commit_link(repo_find_unique_abbrev(the_repository, oid, DEFAULT_ABBREV), detail, + NULL, ctx.qry.head, oid_to_hex(oid), suspect->path); + html("</span>"); + free(detail); + + if (!repo_parse_commit(the_repository, suspect->commit) && suspect->commit->parents) { + struct commit *parent = suspect->commit->parents->item; + + html(" "); + cgit_blame_link("^", "Blame the previous revision", NULL, + ctx.qry.head, oid_to_hex(&parent->object.oid), + suspect->path); + } + + while (line++ < ent->num_lines) + html("\n"); +} + +static void emit_blame_entry_linenumber(struct blame_entry *ent) +{ + const char *numberfmt = "<a id='n%1$d' href='#n%1$d'>%1$d</a>\n"; + + unsigned long lineno = ent->lno; + while (lineno < ent->lno + ent->num_lines) + htmlf(numberfmt, ++lineno); +} + +static void emit_blame_entry_line_background(struct blame_scoreboard *sb, + struct blame_entry *ent) +{ + unsigned long line; + size_t len, maxlen = 2; + const char* pos, *endpos; + + for (line = ent->lno; line < ent->lno + ent->num_lines; line++) { + html("\n"); + pos = blame_nth_line(sb, line); + endpos = blame_nth_line(sb, line + 1); + len = 0; + while (pos < endpos) { + len++; + if (*pos++ == '\t') + len = (len + 7) & ~7; + } + if (len > maxlen) + maxlen = len; + } + + for (len = 0; len < maxlen - 1; len++) + html(" "); +} + +struct walk_tree_context { + char *curr_rev; + int match_baselen; + int state; +}; + +static void print_object(const struct object_id *oid, const char *path, + const char *basename, const char *rev) +{ + enum object_type type; + char *buf; + unsigned long size; + struct strvec rev_argv = STRVEC_INIT; + struct rev_info revs; + struct blame_scoreboard sb; + struct blame_origin *o; + struct blame_entry *ent = NULL; + + type = oid_object_info(the_repository, oid, &size); + if (type == OBJ_BAD) { + cgit_print_error_page(404, "Not found", "Bad object name: %s", + oid_to_hex(oid)); + return; + } + + buf = repo_read_object_file(the_repository, oid, &type, &size); + if (!buf) { + cgit_print_error_page(500, "Internal server error", + "Error reading object %s", oid_to_hex(oid)); + return; + } + + strvec_push(&rev_argv, "blame"); + strvec_push(&rev_argv, rev); + repo_init_revisions(the_repository, &revs, NULL); + revs.diffopt.flags.allow_textconv = 1; + setup_revisions(rev_argv.nr, rev_argv.v, &revs, NULL); + init_scoreboard(&sb); + sb.revs = &revs; + sb.repo = the_repository; + sb.path = path; + setup_scoreboard(&sb, &o); + o->suspects = blame_entry_prepend(NULL, 0, sb.num_lines, o); + prio_queue_put(&sb.commits, o->commit); + blame_origin_decref(o); + sb.ent = NULL; + sb.path = path; + assign_blame(&sb, 0); + blame_sort_final(&sb); + blame_coalesce(&sb); + + cgit_set_title_from_path(path); + + cgit_print_layout_start(); + htmlf("blob: %s (", oid_to_hex(oid)); + cgit_plain_link("plain", NULL, NULL, ctx.qry.head, rev, path); + html(") ("); + cgit_tree_link("tree", NULL, NULL, ctx.qry.head, rev, path); + html(")\n"); + + if (buffer_is_binary(buf, size)) { + html("<div class='error'>blob is binary.</div>"); + goto cleanup; + } + if (ctx.cfg.max_blob_size && size / 1024 > ctx.cfg.max_blob_size) { + htmlf("<div class='error'>blob size (%ldKB)" + " exceeds display size limit (%dKB).</div>", + size / 1024, ctx.cfg.max_blob_size); + goto cleanup; + } + + html("<table class='blame blob'>\n<tr>\n"); + + /* Commit hashes */ + html("<td class='hashes'>"); + for (ent = sb.ent; ent; ent = ent->next) { + html("<div class='alt'><pre>"); + emit_blame_entry_hash(ent); + html("</pre></div>"); + } + html("</td>\n"); + + /* Line numbers */ + if (ctx.cfg.enable_tree_linenumbers) { + html("<td class='linenumbers'>"); + for (ent = sb.ent; ent; ent = ent->next) { + html("<div class='alt'><pre>"); + emit_blame_entry_linenumber(ent); + html("</pre></div>"); + } + html("</td>\n"); + } + + html("<td class='lines'><div>"); + + /* Colored bars behind lines */ + html("<div>"); + for (ent = sb.ent; ent; ) { + struct blame_entry *e = ent->next; + html("<div class='alt'><pre>"); + emit_blame_entry_line_background(&sb, ent); + html("</pre></div>"); + free(ent); + ent = e; + } + html("</div>"); + + free((void *)sb.final_buf); + + /* Lines */ + html("<pre><code>"); + if (ctx.repo->source_filter) { + char *filter_arg = xstrdup(basename); + cgit_open_filter(ctx.repo->source_filter, filter_arg); + html_raw(buf, size); + cgit_close_filter(ctx.repo->source_filter); + free(filter_arg); + } else { + html_txt(buf); + } + html("</code></pre>"); + + html("</div></td>\n"); + + html("</tr>\n</table>\n"); + + cgit_print_layout_end(); + +cleanup: + free(buf); +} + +static int walk_tree(const struct object_id *oid, struct strbuf *base, + const char *pathname, unsigned mode, void *cbdata) +{ + struct walk_tree_context *walk_tree_ctx = cbdata; + + if (base->len == walk_tree_ctx->match_baselen) { + if (S_ISREG(mode)) { + struct strbuf buffer = STRBUF_INIT; + strbuf_addbuf(&buffer, base); + strbuf_addstr(&buffer, pathname); + print_object(oid, buffer.buf, pathname, + walk_tree_ctx->curr_rev); + strbuf_release(&buffer); + walk_tree_ctx->state = 1; + } else if (S_ISDIR(mode)) { + walk_tree_ctx->state = 2; + } + } else if (base->len < INT_MAX + && (int)base->len > walk_tree_ctx->match_baselen) { + walk_tree_ctx->state = 2; + } else if (S_ISDIR(mode)) { + return READ_TREE_RECURSIVE; + } + return 0; +} + +static int basedir_len(const char *path) +{ + char *p = strrchr(path, '/'); + if (p) + return p - path + 1; + return 0; +} + +void cgit_print_blame(void) +{ + const char *rev = ctx.qry.oid; + struct object_id oid; + struct commit *commit; + struct pathspec_item path_items = { + .match = ctx.qry.path, + .len = ctx.qry.path ? strlen(ctx.qry.path) : 0 + }; + struct pathspec paths = { + .nr = 1, + .items = &path_items + }; + struct walk_tree_context walk_tree_ctx = { + .state = 0 + }; + + if (!rev) + rev = ctx.qry.head; + + if (repo_get_oid(the_repository, rev, &oid)) { + cgit_print_error_page(404, "Not found", + "Invalid revision name: %s", rev); + return; + } + commit = lookup_commit_reference(the_repository, &oid); + if (!commit || repo_parse_commit(the_repository, commit)) { + cgit_print_error_page(404, "Not found", + "Invalid commit reference: %s", rev); + return; + } + + walk_tree_ctx.curr_rev = xstrdup(rev); + walk_tree_ctx.match_baselen = (path_items.match) ? + basedir_len(path_items.match) : -1; + + read_tree(the_repository, repo_get_commit_tree(the_repository, commit), + &paths, walk_tree, &walk_tree_ctx); + if (!walk_tree_ctx.state) + cgit_print_error_page(404, "Not found", "Not found"); + else if (walk_tree_ctx.state == 2) + cgit_print_error_page(404, "No blame for folders", + "Blame is not available for folders."); + + free(walk_tree_ctx.curr_rev); +} diff --git a/third_party/cgit/ui-blame.h b/third_party/cgit/ui-blame.h new file mode 100644 index 0000000000..5b97e03591 --- /dev/null +++ b/third_party/cgit/ui-blame.h @@ -0,0 +1,6 @@ +#ifndef UI_BLAME_H +#define UI_BLAME_H + +extern void cgit_print_blame(void); + +#endif /* UI_BLAME_H */ diff --git a/third_party/cgit/ui-blob.c b/third_party/cgit/ui-blob.c new file mode 100644 index 0000000000..08f94ee97e --- /dev/null +++ b/third_party/cgit/ui-blob.c @@ -0,0 +1,182 @@ +/* ui-blob.c: show blob content + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "ui-blob.h" +#include "html.h" +#include "ui-shared.h" + +struct walk_tree_context { + const char *match_path; + struct object_id *matched_oid; + unsigned int found_path:1; + unsigned int file_only:1; +}; + +static int walk_tree(const struct object_id *oid, struct strbuf *base, + const char *pathname, unsigned mode, void *cbdata) +{ + struct walk_tree_context *walk_tree_ctx = cbdata; + + if (walk_tree_ctx->file_only && !S_ISREG(mode)) + return READ_TREE_RECURSIVE; + if (strncmp(base->buf, walk_tree_ctx->match_path, base->len) + || strcmp(walk_tree_ctx->match_path + base->len, pathname)) + return READ_TREE_RECURSIVE; + oidcpy(walk_tree_ctx->matched_oid, oid); + walk_tree_ctx->found_path = 1; + return 0; +} + +int cgit_ref_path_exists(const char *path, const char *ref, int file_only) +{ + struct object_id oid; + unsigned long size; + struct pathspec_item path_items = { + .match = xstrdup(path), + .len = strlen(path) + }; + struct pathspec paths = { + .nr = 1, + .items = &path_items + }; + struct walk_tree_context walk_tree_ctx = { + .match_path = path, + .matched_oid = &oid, + .found_path = 0, + .file_only = file_only + }; + + if (repo_get_oid(the_repository, ref, &oid)) + goto done; + if (oid_object_info(the_repository, &oid, &size) != OBJ_COMMIT) + goto done; + read_tree(the_repository, + repo_get_commit_tree(the_repository, lookup_commit_reference(the_repository, &oid)), + &paths, walk_tree, &walk_tree_ctx); + +done: + free(path_items.match); + return walk_tree_ctx.found_path; +} + +int cgit_print_file(char *path, const char *head, int file_only) +{ + struct object_id oid; + enum object_type type; + char *buf; + unsigned long size; + struct commit *commit; + struct pathspec_item path_items = { + .match = path, + .len = strlen(path) + }; + struct pathspec paths = { + .nr = 1, + .items = &path_items + }; + struct walk_tree_context walk_tree_ctx = { + .match_path = path, + .matched_oid = &oid, + .found_path = 0, + .file_only = file_only + }; + + if (repo_get_oid(the_repository, head, &oid)) + return -1; + type = oid_object_info(the_repository, &oid, &size); + if (type == OBJ_COMMIT) { + commit = lookup_commit_reference(the_repository, &oid); + read_tree(the_repository, repo_get_commit_tree(the_repository, commit), + &paths, walk_tree, &walk_tree_ctx); + if (!walk_tree_ctx.found_path) + return -1; + type = oid_object_info(the_repository, &oid, &size); + } + if (type == OBJ_BAD) + return -1; + buf = repo_read_object_file(the_repository, &oid, &type, &size); + if (!buf) + return -1; + buf[size] = '\0'; + html_raw(buf, size); + free(buf); + return 0; +} + +void cgit_print_blob(const char *hex, char *path, const char *head, int file_only) +{ + struct object_id oid; + enum object_type type; + char *buf; + unsigned long size; + struct commit *commit; + struct pathspec_item path_items = { + .match = path, + .len = path ? strlen(path) : 0 + }; + struct pathspec paths = { + .nr = 1, + .items = &path_items + }; + struct walk_tree_context walk_tree_ctx = { + .match_path = path, + .matched_oid = &oid, + .found_path = 0, + .file_only = file_only + }; + + if (hex) { + if (get_oid_hex(hex, &oid)) { + cgit_print_error_page(400, "Bad request", + "Bad hex value: %s", hex); + return; + } + } else { + if (repo_get_oid(the_repository, head, &oid)) { + cgit_print_error_page(404, "Not found", + "Bad ref: %s", head); + return; + } + } + + type = oid_object_info(the_repository, &oid, &size); + + if ((!hex) && type == OBJ_COMMIT && path) { + commit = lookup_commit_reference(the_repository, &oid); + read_tree(the_repository, repo_get_commit_tree(the_repository, commit), + &paths, walk_tree, &walk_tree_ctx); + type = oid_object_info(the_repository, &oid, &size); + } + + if (type == OBJ_BAD) { + cgit_print_error_page(404, "Not found", + "Bad object name: %s", hex); + return; + } + + buf = repo_read_object_file(the_repository, &oid, &type, &size); + if (!buf) { + cgit_print_error_page(500, "Internal server error", + "Error reading object %s", hex); + return; + } + + buf[size] = '\0'; + if (buffer_is_binary(buf, size)) + ctx.page.mimetype = "application/octet-stream"; + else + ctx.page.mimetype = "text/plain"; + ctx.page.filename = path; + + html("X-Content-Type-Options: nosniff\n"); + html("Content-Security-Policy: default-src 'none'\n"); + cgit_print_http_headers(); + html_raw(buf, size); + free(buf); +} diff --git a/third_party/cgit/ui-blob.h b/third_party/cgit/ui-blob.h new file mode 100644 index 0000000000..16847b20b1 --- /dev/null +++ b/third_party/cgit/ui-blob.h @@ -0,0 +1,8 @@ +#ifndef UI_BLOB_H +#define UI_BLOB_H + +extern int cgit_ref_path_exists(const char *path, const char *ref, int file_only); +extern int cgit_print_file(char *path, const char *head, int file_only); +extern void cgit_print_blob(const char *hex, char *path, const char *head, int file_only); + +#endif /* UI_BLOB_H */ diff --git a/third_party/cgit/ui-clone.c b/third_party/cgit/ui-clone.c new file mode 100644 index 0000000000..5dccb63976 --- /dev/null +++ b/third_party/cgit/ui-clone.c @@ -0,0 +1,126 @@ +/* ui-clone.c: functions for http cloning, based on + * git's http-backend.c by Shawn O. Pearce + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "ui-clone.h" +#include "html.h" +#include "ui-shared.h" +#include "packfile.h" +#include "object-store.h" + +static int print_ref_info(const char *refname, const struct object_id *oid, + int flags, void *cb_data) +{ + struct object *obj; + + if (!(obj = parse_object(the_repository, oid))) + return 0; + + htmlf("%s\t%s\n", oid_to_hex(oid), refname); + if (obj->type == OBJ_TAG) { + if (!(obj = deref_tag(the_repository, obj, refname, 0))) + return 0; + htmlf("%s\t%s^{}\n", oid_to_hex(&obj->oid), refname); + } + return 0; +} + +static void print_pack_info(void) +{ + struct packed_git *pack; + char *offset; + + ctx.page.mimetype = "text/plain"; + ctx.page.filename = "objects/info/packs"; + cgit_print_http_headers(); + reprepare_packed_git(the_repository); + for (pack = get_packed_git(the_repository); pack; pack = pack->next) { + if (pack->pack_local) { + offset = strrchr(pack->pack_name, '/'); + if (offset && offset[1] != '\0') + ++offset; + else + offset = pack->pack_name; + htmlf("P %s\n", offset); + } + } +} + +static void send_file(const char *path) +{ + struct stat st; + + if (stat(path, &st)) { + switch (errno) { + case ENOENT: + cgit_print_error_page(404, "Not found", "Not found"); + break; + case EACCES: + cgit_print_error_page(403, "Forbidden", "Forbidden"); + break; + default: + cgit_print_error_page(400, "Bad request", "Bad request"); + } + return; + } + ctx.page.mimetype = "application/octet-stream"; + ctx.page.filename = path; + skip_prefix(path, ctx.repo->path, &ctx.page.filename); + skip_prefix(ctx.page.filename, "/", &ctx.page.filename); + cgit_print_http_headers(); + html_include(path); +} + +void cgit_clone_info(void) +{ + if (!ctx.qry.path || strcmp(ctx.qry.path, "refs")) { + cgit_print_error_page(400, "Bad request", "Bad request"); + return; + } + + ctx.page.mimetype = "text/plain"; + ctx.page.filename = "info/refs"; + cgit_print_http_headers(); + for_each_ref(print_ref_info, NULL); +} + +void cgit_clone_objects(void) +{ + char *p; + + if (!ctx.qry.path) + goto err; + + if (!strcmp(ctx.qry.path, "info/packs")) { + print_pack_info(); + return; + } + + /* Avoid directory traversal by forbidding "..", but also work around + * other funny business by just specifying a fairly strict format. For + * example, now we don't have to stress out about the Cygwin port. + */ + for (p = ctx.qry.path; *p; ++p) { + if (*p == '.' && *(p + 1) == '.') + goto err; + if (!isalnum(*p) && *p != '/' && *p != '.' && *p != '-') + goto err; + } + + send_file(git_path("objects/%s", ctx.qry.path)); + return; + +err: + cgit_print_error_page(400, "Bad request", "Bad request"); +} + +void cgit_clone_head(void) +{ + send_file(git_path("%s", "HEAD")); +} diff --git a/third_party/cgit/ui-clone.h b/third_party/cgit/ui-clone.h new file mode 100644 index 0000000000..3e460a3dbc --- /dev/null +++ b/third_party/cgit/ui-clone.h @@ -0,0 +1,8 @@ +#ifndef UI_CLONE_H +#define UI_CLONE_H + +void cgit_clone_info(void); +void cgit_clone_objects(void); +void cgit_clone_head(void); + +#endif /* UI_CLONE_H */ diff --git a/third_party/cgit/ui-commit.c b/third_party/cgit/ui-commit.c new file mode 100644 index 0000000000..6517e50cc6 --- /dev/null +++ b/third_party/cgit/ui-commit.c @@ -0,0 +1,148 @@ +/* ui-commit.c: generate commit view + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "ui-commit.h" +#include "html.h" +#include "ui-shared.h" +#include "ui-diff.h" +#include "ui-log.h" + +void cgit_print_commit(char *hex, const char *prefix) +{ + struct commit *commit, *parent; + struct commitinfo *info, *parent_info; + struct commit_list *p; + struct strbuf notes = STRBUF_INIT; + struct object_id oid; + char *tmp, *tmp2; + int parents = 0; + + if (!hex) + hex = ctx.qry.head; + + if (repo_get_oid(the_repository, hex, &oid)) { + cgit_print_error_page(400, "Bad request", + "Bad object id: %s", hex); + return; + } + commit = lookup_commit_reference(the_repository, &oid); + if (!commit) { + cgit_print_error_page(404, "Not found", + "Bad commit reference: %s", hex); + return; + } + info = cgit_parse_commit(commit); + + format_display_notes(&oid, ¬es, PAGE_ENCODING, 1); + + load_ref_decorations(NULL, DECORATE_FULL_REFS); + + ctx.page.title = fmtalloc("%s - %s", info->subject, ctx.page.title); + cgit_print_layout_start(); + cgit_print_diff_ctrls(); + html("<table summary='commit info' class='commit-info'>\n"); + html("<tr><th>author</th><td>"); + cgit_open_filter(ctx.repo->email_filter, info->author_email, "commit"); + html_txt(info->author); + if (!ctx.cfg.noplainemail) { + html(" "); + html_txt(info->author_email); + } + cgit_close_filter(ctx.repo->email_filter); + html("</td><td class='right'>"); + html_txt(show_date(info->author_date, info->author_tz, + cgit_date_mode(DATE_DOTTIME))); + html("</td></tr>\n"); + html("<tr><th>committer</th><td>"); + cgit_open_filter(ctx.repo->email_filter, info->committer_email, "commit"); + html_txt(info->committer); + if (!ctx.cfg.noplainemail) { + html(" "); + html_txt(info->committer_email); + } + cgit_close_filter(ctx.repo->email_filter); + html("</td><td class='right'>"); + html_txt(show_date(info->committer_date, info->committer_tz, + cgit_date_mode(DATE_DOTTIME))); + html("</td></tr>\n"); + html("<tr><th>commit</th><td colspan='2' class='oid'>"); + tmp = oid_to_hex(&commit->object.oid); + cgit_commit_link(tmp, NULL, NULL, ctx.qry.head, tmp, prefix); + html(" ("); + cgit_patch_link("patch", NULL, NULL, NULL, tmp, prefix); + html(")</td></tr>\n"); + html("<tr><th>tree</th><td colspan='2' class='oid'>"); + tmp = xstrdup(hex); + cgit_tree_link(oid_to_hex(get_commit_tree_oid(commit)), NULL, NULL, + ctx.qry.head, tmp, NULL); + if (prefix) { + html(" /"); + cgit_tree_link(prefix, NULL, NULL, ctx.qry.head, tmp, prefix); + } + free(tmp); + html("</td></tr>\n"); + for (p = commit->parents; p; p = p->next) { + parent = lookup_commit_reference(the_repository, &p->item->object.oid); + if (!parent) { + html("<tr><td colspan='3'>"); + cgit_print_error("Error reading parent commit"); + html("</td></tr>"); + continue; + } + html("<tr><th>parent</th>" + "<td colspan='2' class='oid'>"); + tmp = tmp2 = oid_to_hex(&p->item->object.oid); + if (ctx.repo->enable_subject_links) { + parent_info = cgit_parse_commit(parent); + tmp2 = parent_info->subject; + } + cgit_commit_link(tmp2, NULL, NULL, ctx.qry.head, tmp, prefix); + html(" ("); + cgit_diff_link("diff", NULL, NULL, ctx.qry.head, hex, + oid_to_hex(&p->item->object.oid), prefix); + html(")</td></tr>"); + parents++; + } + if (ctx.repo->snapshots) { + html("<tr><th>download</th><td colspan='2' class='oid'>"); + cgit_print_snapshot_links(ctx.repo, hex, "<br/>"); + html("</td></tr>"); + } + html("</table>\n"); + html("<div class='commit-subject'>"); + cgit_open_filter(ctx.repo->commit_filter); + html_txt(info->subject); + cgit_close_filter(ctx.repo->commit_filter); + show_commit_decorations(commit); + html("</div>"); + html("<pre class='commit-msg'>"); + cgit_open_filter(ctx.repo->commit_filter); + html_txt(info->msg); + cgit_close_filter(ctx.repo->commit_filter); + html("</pre>"); + if (notes.len != 0) { + html("<div class='notes-header'>Notes</div>"); + html("<div class='notes'>"); + cgit_open_filter(ctx.repo->commit_filter); + html_txt(notes.buf); + cgit_close_filter(ctx.repo->commit_filter); + html("</div>"); + html("<div class='notes-footer'></div>"); + } + if (parents < 3) { + if (parents) + tmp = oid_to_hex(&commit->parents->item->object.oid); + else + tmp = NULL; + cgit_print_diff(ctx.qry.oid, tmp, prefix, 0, 0); + } + strbuf_release(¬es); + cgit_free_commitinfo(info); + cgit_print_layout_end(); +} diff --git a/third_party/cgit/ui-commit.h b/third_party/cgit/ui-commit.h new file mode 100644 index 0000000000..8198b4bacc --- /dev/null +++ b/third_party/cgit/ui-commit.h @@ -0,0 +1,6 @@ +#ifndef UI_COMMIT_H +#define UI_COMMIT_H + +extern void cgit_print_commit(char *hex, const char *prefix); + +#endif /* UI_COMMIT_H */ diff --git a/third_party/cgit/ui-diff.c b/third_party/cgit/ui-diff.c new file mode 100644 index 0000000000..a82313fc64 --- /dev/null +++ b/third_party/cgit/ui-diff.c @@ -0,0 +1,505 @@ +/* ui-diff.c: show diff between two blobs + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "ui-diff.h" +#include "html.h" +#include "ui-shared.h" +#include "ui-ssdiff.h" + +struct object_id old_rev_oid[1]; +struct object_id new_rev_oid[1]; + +static int files, slots; +static int total_adds, total_rems, max_changes; +static int lines_added, lines_removed; + +static struct fileinfo { + char status; + struct object_id old_oid[1]; + struct object_id new_oid[1]; + unsigned short old_mode; + unsigned short new_mode; + char *old_path; + char *new_path; + unsigned int added; + unsigned int removed; + unsigned long old_size; + unsigned long new_size; + unsigned int binary:1; +} *items; + +static int use_ssdiff = 0; +static struct diff_filepair *current_filepair; +static const char *current_prefix; + +struct diff_filespec *cgit_get_current_old_file(void) +{ + return current_filepair->one; +} + +struct diff_filespec *cgit_get_current_new_file(void) +{ + return current_filepair->two; +} + +static void print_fileinfo(struct fileinfo *info) +{ + char *class; + + switch (info->status) { + case DIFF_STATUS_ADDED: + class = "add"; + break; + case DIFF_STATUS_COPIED: + class = "cpy"; + break; + case DIFF_STATUS_DELETED: + class = "del"; + break; + case DIFF_STATUS_MODIFIED: + class = "upd"; + break; + case DIFF_STATUS_RENAMED: + class = "mov"; + break; + case DIFF_STATUS_TYPE_CHANGED: + class = "typ"; + break; + case DIFF_STATUS_UNKNOWN: + class = "unk"; + break; + case DIFF_STATUS_UNMERGED: + class = "stg"; + break; + default: + die("bug: unhandled diff status %c", info->status); + } + + html("<tr>"); + html("<td class='mode'>"); + if (is_null_oid(info->new_oid)) { + cgit_print_filemode(info->old_mode); + } else { + cgit_print_filemode(info->new_mode); + } + + if (info->old_mode != info->new_mode && + !is_null_oid(info->old_oid) && + !is_null_oid(info->new_oid)) { + html("<span class='modechange'>["); + cgit_print_filemode(info->old_mode); + html("]</span>"); + } + htmlf("</td><td class='%s'>", class); + cgit_diff_link(info->new_path, NULL, NULL, ctx.qry.head, ctx.qry.oid, + ctx.qry.oid2, info->new_path); + if (info->status == DIFF_STATUS_COPIED || info->status == DIFF_STATUS_RENAMED) { + htmlf(" (%s from ", + info->status == DIFF_STATUS_COPIED ? "copied" : "renamed"); + html_txt(info->old_path); + html(")"); + } + html("</td><td class='right'>"); + if (info->binary) { + htmlf("bin</td><td class='graph'>%ld -> %ld bytes", + info->old_size, info->new_size); + return; + } + htmlf("%d", info->added + info->removed); + html("</td><td class='graph'>"); + htmlf("<table summary='file diffstat' width='%d%%'><tr>", (max_changes > 100 ? 100 : max_changes)); + htmlf("<td class='add' style='width: %.1f%%;'/>", + info->added * 100.0 / max_changes); + htmlf("<td class='rem' style='width: %.1f%%;'/>", + info->removed * 100.0 / max_changes); + htmlf("<td class='none' style='width: %.1f%%;'/>", + (max_changes - info->removed - info->added) * 100.0 / max_changes); + html("</tr></table></td></tr>\n"); +} + +static void count_diff_lines(char *line, int len) +{ + if (line && (len > 0)) { + if (line[0] == '+') + lines_added++; + else if (line[0] == '-') + lines_removed++; + } +} + +static int show_filepair(struct diff_filepair *pair) +{ + /* Always show if we have no limiting prefix. */ + if (!current_prefix) + return 1; + + /* Show if either path in the pair begins with the prefix. */ + if (starts_with(pair->one->path, current_prefix) || + starts_with(pair->two->path, current_prefix)) + return 1; + + /* Otherwise we don't want to show this filepair. */ + return 0; +} + +static void inspect_filepair(struct diff_filepair *pair) +{ + int binary = 0; + unsigned long old_size = 0; + unsigned long new_size = 0; + + if (!show_filepair(pair)) + return; + + files++; + lines_added = 0; + lines_removed = 0; + cgit_diff_files(&pair->one->oid, &pair->two->oid, &old_size, &new_size, + &binary, 0, ctx.qry.ignorews, count_diff_lines); + if (files >= slots) { + if (slots == 0) + slots = 4; + else + slots = slots * 2; + items = xrealloc(items, slots * sizeof(struct fileinfo)); + } + items[files-1].status = pair->status; + oidcpy(items[files-1].old_oid, &pair->one->oid); + oidcpy(items[files-1].new_oid, &pair->two->oid); + items[files-1].old_mode = pair->one->mode; + items[files-1].new_mode = pair->two->mode; + items[files-1].old_path = xstrdup(pair->one->path); + items[files-1].new_path = xstrdup(pair->two->path); + items[files-1].added = lines_added; + items[files-1].removed = lines_removed; + items[files-1].old_size = old_size; + items[files-1].new_size = new_size; + items[files-1].binary = binary; + if (lines_added + lines_removed > max_changes) + max_changes = lines_added + lines_removed; + total_adds += lines_added; + total_rems += lines_removed; +} + +static void cgit_print_diffstat(const struct object_id *old_oid, + const struct object_id *new_oid, + const char *prefix) +{ + int i; + + html("<div class='diffstat-header'>"); + cgit_diff_link("Diffstat", NULL, NULL, ctx.qry.head, ctx.qry.oid, + ctx.qry.oid2, NULL); + if (prefix) { + html(" (limited to '"); + html_txt(prefix); + html("')"); + } + html("</div>"); + html("<table summary='diffstat' class='diffstat'>"); + max_changes = 0; + cgit_diff_tree(old_oid, new_oid, inspect_filepair, prefix, + ctx.qry.ignorews); + for (i = 0; i<files; i++) + print_fileinfo(&items[i]); + html("</table>"); + html("<div class='diffstat-summary'>"); + htmlf("%d files changed, %d insertions, %d deletions", + files, total_adds, total_rems); + html("</div>"); +} + + +/* + * print a single line returned from xdiff + */ +static void print_line(char *line, int len) +{ + char *class = "ctx"; + char c = line[len-1]; + + if (line[0] == '+') + class = "add"; + else if (line[0] == '-') + class = "del"; + else if (line[0] == '@') + class = "hunk"; + + htmlf("<span class='%s'>", class); + line[len-1] = '\0'; + html_txt(line); + line[len-1] = c; + html("</span>\n"); +} + +static void header(const struct object_id *oid1, char *path1, int mode1, + const struct object_id *oid2, char *path2, int mode2) +{ + char *abbrev1, *abbrev2; + int subproject; + + subproject = (S_ISGITLINK(mode1) || S_ISGITLINK(mode2)); + html("<span class='head'>"); + html("diff --git a/"); + html_txt(path1); + html(" b/"); + html_txt(path2); + html("\n"); + + if (mode1 == 0) + htmlf("new file mode %.6o\n", mode2); + + if (mode2 == 0) + htmlf("deleted file mode %.6o\n", mode1); + + if (!subproject) { + abbrev1 = xstrdup(repo_find_unique_abbrev(the_repository, oid1, DEFAULT_ABBREV)); + abbrev2 = xstrdup(repo_find_unique_abbrev(the_repository, oid2, DEFAULT_ABBREV)); + htmlf("index %s..%s", abbrev1, abbrev2); + free(abbrev1); + free(abbrev2); + if (mode1 != 0 && mode2 != 0) { + htmlf(" %.6o", mode1); + if (mode2 != mode1) + htmlf("..%.6o", mode2); + } + html("\n"); + if (is_null_oid(oid1)) { + path1 = "dev/null"; + html("--- /"); + } else + html("--- a/"); + if (mode1 != 0) + cgit_tree_link(path1, NULL, NULL, ctx.qry.head, + oid_to_hex(old_rev_oid), path1); + else + html_txt(path1); + html("\n"); + if (is_null_oid(oid2)) { + path2 = "dev/null"; + html("+++ /"); + } else + html("+++ b/"); + if (mode2 != 0) + cgit_tree_link(path2, NULL, NULL, ctx.qry.head, + oid_to_hex(new_rev_oid), path2); + else + html_txt(path2); + html("\n"); + } + html("</span>"); +} + +static void filepair_cb(struct diff_filepair *pair) +{ + unsigned long old_size = 0; + unsigned long new_size = 0; + int binary = 0; + linediff_fn print_line_fn = print_line; + + if (!show_filepair(pair)) + return; + + current_filepair = pair; + if (use_ssdiff) { + cgit_ssdiff_header_begin(); + print_line_fn = cgit_ssdiff_line_cb; + } + header(&pair->one->oid, pair->one->path, pair->one->mode, + &pair->two->oid, pair->two->path, pair->two->mode); + if (use_ssdiff) + cgit_ssdiff_header_end(); + if (S_ISGITLINK(pair->one->mode) || S_ISGITLINK(pair->two->mode)) { + if (S_ISGITLINK(pair->one->mode)) + print_line_fn(fmt("-Subproject %s", oid_to_hex(&pair->one->oid)), 52); + if (S_ISGITLINK(pair->two->mode)) + print_line_fn(fmt("+Subproject %s", oid_to_hex(&pair->two->oid)), 52); + if (use_ssdiff) + cgit_ssdiff_footer(); + return; + } + if (cgit_diff_files(&pair->one->oid, &pair->two->oid, &old_size, + &new_size, &binary, ctx.qry.context, + ctx.qry.ignorews, print_line_fn)) + cgit_print_error("Error running diff"); + if (binary) { + if (use_ssdiff) + html("<tr><td colspan='4'>Binary files differ</td></tr>"); + else + html("Binary files differ"); + } + if (use_ssdiff) + cgit_ssdiff_footer(); +} + +void cgit_print_diff_ctrls(void) +{ + int i, curr; + + html("<div class='cgit-panel'>"); + html("<b>diff options</b>"); + html("<form method='get'>"); + cgit_add_hidden_formfields(1, 0, ctx.qry.page); + html("<table>"); + html("<tr><td colspan='2'/></tr>"); + html("<tr>"); + html("<td class='label'>context:</td>"); + html("<td class='ctrl'>"); + html("<select name='context' onchange='this.form.submit();'>"); + curr = ctx.qry.context; + if (!curr) + curr = 3; + for (i = 1; i <= 10; i++) + html_intoption(i, fmt("%d", i), curr); + for (i = 15; i <= 40; i += 5) + html_intoption(i, fmt("%d", i), curr); + html("</select>"); + html("</td>"); + html("</tr><tr>"); + html("<td class='label'>space:</td>"); + html("<td class='ctrl'>"); + html("<select name='ignorews' onchange='this.form.submit();'>"); + html_intoption(0, "include", ctx.qry.ignorews); + html_intoption(1, "ignore", ctx.qry.ignorews); + html("</select>"); + html("</td>"); + html("</tr><tr>"); + html("<td class='label'>mode:</td>"); + html("<td class='ctrl'>"); + html("<select name='dt' onchange='this.form.submit();'>"); + curr = ctx.qry.has_difftype ? ctx.qry.difftype : ctx.cfg.difftype; + html_intoption(0, "unified", curr); + html_intoption(1, "ssdiff", curr); + html_intoption(2, "stat only", curr); + html("</select></td></tr>"); + html("<tr><td/><td class='ctrl'>"); + html("<noscript><input type='submit' value='reload'/></noscript>"); + html("</td></tr></table>"); + html("</form>"); + html("</div>"); +} + +void cgit_print_diff(const char *new_rev, const char *old_rev, + const char *prefix, int show_ctrls, int raw) +{ + struct commit *commit, *commit2; + const struct object_id *old_tree_oid, *new_tree_oid; + diff_type difftype; + + /* + * If "follow" is set then the diff machinery needs to examine the + * entire commit to detect renames so we must limit the paths in our + * own callbacks and not pass the prefix to the diff machinery. + */ + if (ctx.qry.follow && ctx.cfg.enable_follow_links) { + current_prefix = prefix; + prefix = ""; + } else { + current_prefix = NULL; + } + + if (!new_rev) + new_rev = ctx.qry.head; + if (repo_get_oid(the_repository, new_rev, new_rev_oid)) { + cgit_print_error_page(404, "Not found", + "Bad object name: %s", new_rev); + return; + } + commit = lookup_commit_reference(the_repository, new_rev_oid); + if (!commit || repo_parse_commit(the_repository, commit)) { + cgit_print_error_page(404, "Not found", + "Bad commit: %s", oid_to_hex(new_rev_oid)); + return; + } + new_tree_oid = get_commit_tree_oid(commit); + + if (old_rev) { + if (repo_get_oid(the_repository, old_rev, old_rev_oid)) { + cgit_print_error_page(404, "Not found", + "Bad object name: %s", old_rev); + return; + } + } else if (commit->parents && commit->parents->item) { + oidcpy(old_rev_oid, &commit->parents->item->object.oid); + } else { + oidclr(old_rev_oid); + } + + if (!is_null_oid(old_rev_oid)) { + commit2 = lookup_commit_reference(the_repository, old_rev_oid); + if (!commit2 || repo_parse_commit(the_repository, commit2)) { + cgit_print_error_page(404, "Not found", + "Bad commit: %s", oid_to_hex(old_rev_oid)); + return; + } + old_tree_oid = get_commit_tree_oid(commit2); + } else { + old_tree_oid = NULL; + } + + if (raw) { + struct diff_options diffopt; + + repo_diff_setup(the_repository, &diffopt); + diffopt.output_format = DIFF_FORMAT_PATCH; + diffopt.flags.recursive = 1; + diff_setup_done(&diffopt); + + ctx.page.mimetype = "text/plain"; + cgit_print_http_headers(); + if (old_tree_oid) { + diff_tree_oid(old_tree_oid, new_tree_oid, "", + &diffopt); + } else { + diff_root_tree_oid(new_tree_oid, "", &diffopt); + } + diffcore_std(&diffopt); + diff_flush(&diffopt); + + return; + } + + difftype = ctx.qry.has_difftype ? ctx.qry.difftype : ctx.cfg.difftype; + use_ssdiff = difftype == DIFF_SSDIFF; + + if (show_ctrls) { + cgit_print_layout_start(); + cgit_print_diff_ctrls(); + } + + /* + * Clicking on a link to a file in the diff stat should show a diff + * of the file, showing the diff stat limited to a single file is + * pretty useless. All links from this point on will be to + * individual files, so we simply reset the difftype in the query + * here to avoid propagating DIFF_STATONLY to the individual files. + */ + if (difftype == DIFF_STATONLY) + ctx.qry.difftype = ctx.cfg.difftype; + + cgit_print_diffstat(old_rev_oid, new_rev_oid, prefix); + + if (difftype == DIFF_STATONLY) + return; + + if (use_ssdiff) { + html("<table summary='ssdiff' class='ssdiff'>"); + } else { + html("<table summary='diff' class='diff'>"); + html("<tr><td><pre>"); + } + cgit_diff_tree(old_rev_oid, new_rev_oid, filepair_cb, prefix, + ctx.qry.ignorews); + if (!use_ssdiff) + html("</pre></td></tr>"); + html("</table>"); + + if (show_ctrls) + cgit_print_layout_end(); +} diff --git a/third_party/cgit/ui-diff.h b/third_party/cgit/ui-diff.h new file mode 100644 index 0000000000..39264a164f --- /dev/null +++ b/third_party/cgit/ui-diff.h @@ -0,0 +1,15 @@ +#ifndef UI_DIFF_H +#define UI_DIFF_H + +extern void cgit_print_diff_ctrls(void); + +extern void cgit_print_diff(const char *new_hex, const char *old_hex, + const char *prefix, int show_ctrls, int raw); + +extern struct diff_filespec *cgit_get_current_old_file(void); +extern struct diff_filespec *cgit_get_current_new_file(void); + +extern struct object_id old_rev_oid[1]; +extern struct object_id new_rev_oid[1]; + +#endif /* UI_DIFF_H */ diff --git a/third_party/cgit/ui-log.c b/third_party/cgit/ui-log.c new file mode 100644 index 0000000000..358cdec4e7 --- /dev/null +++ b/third_party/cgit/ui-log.c @@ -0,0 +1,564 @@ +/* ui-log.c: functions for log output + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "ui-log.h" +#include "html.h" +#include "ui-shared.h" +#include "strvec.h" + +static int files, add_lines, rem_lines, lines_counted; + +/* + * The list of available column colors in the commit graph. + */ +static const char *column_colors_html[] = { + "<span class='column1'>", + "<span class='column2'>", + "<span class='column3'>", + "<span class='column4'>", + "<span class='column5'>", + "<span class='column6'>", + "</span>", +}; + +#define COLUMN_COLORS_HTML_MAX (ARRAY_SIZE(column_colors_html) - 1) + +static void count_lines(char *line, int size) +{ + if (size <= 0) + return; + + if (line[0] == '+') + add_lines++; + + else if (line[0] == '-') + rem_lines++; +} + +static void inspect_files(struct diff_filepair *pair) +{ + unsigned long old_size = 0; + unsigned long new_size = 0; + int binary = 0; + + files++; + if (ctx.repo->enable_log_linecount) + cgit_diff_files(&pair->one->oid, &pair->two->oid, &old_size, + &new_size, &binary, 0, ctx.qry.ignorews, + count_lines); +} + +void show_commit_decorations(struct commit *commit) +{ + const struct name_decoration *deco; + static char buf[1024]; + + buf[sizeof(buf) - 1] = 0; + deco = get_name_decoration(&commit->object); + if (!deco) + return; + html("<span class='decoration'>"); + while (deco) { + struct object_id oid_tag, peeled; + int is_annotated = 0; + + strlcpy(buf, prettify_refname(deco->name), sizeof(buf)); + switch(deco->type) { + case DECORATION_NONE: + /* If it is a depot revision, display it, otherwise + * ... */ + if (strncmp("refs/r/", buf, 7) == 0) { + html(" "); + cgit_log_link(/* trim 'refs/' */ buf + 5, + NULL, "rev-deco", buf, NULL, + ctx.qry.vpath, 0, NULL, NULL, + ctx.qry.showmsg, 0); + } + + /* If the git-core doesn't recognize it, + * don't display anything. */ + break; + case DECORATION_REF_LOCAL: + html(" "); + cgit_log_link(buf, NULL, "branch-deco", buf, NULL, + ctx.qry.vpath, 0, NULL, NULL, + ctx.qry.showmsg, 0); + break; + case DECORATION_REF_TAG: + html(" "); + if (!read_ref(deco->name, &oid_tag) && !peel_iterated_oid(&oid_tag, &peeled)) + is_annotated = !oideq(&oid_tag, &peeled); + cgit_tag_link(buf, NULL, is_annotated ? "tag-annotated-deco" : "tag-deco", buf); + break; + case DECORATION_REF_REMOTE: + if (!ctx.repo->enable_remote_branches) + break; + html(" "); + cgit_log_link(buf, NULL, "remote-deco", NULL, + oid_to_hex(&commit->object.oid), + ctx.qry.vpath, 0, NULL, NULL, + ctx.qry.showmsg, 0); + break; + default: + html(" "); + cgit_commit_link(buf, NULL, "deco", ctx.qry.head, + oid_to_hex(&commit->object.oid), + ctx.qry.vpath); + break; + } + deco = deco->next; + } + html("</span>"); +} + +static void handle_rename(struct diff_filepair *pair) +{ + /* + * After we have seen a rename, we generate links to the previous + * name of the file so that commit & diff views get fed the path + * that is correct for the commit they are showing, avoiding the + * need to walk the entire history leading back to every commit we + * show in order detect renames. + */ + if (0 != strcmp(ctx.qry.vpath, pair->two->path)) { + free(ctx.qry.vpath); + ctx.qry.vpath = xstrdup(pair->two->path); + } + inspect_files(pair); +} + +static int show_commit(struct commit *commit, struct rev_info *revs) +{ + struct commit_list *parents = commit->parents; + struct commit *parent; + int found = 0, saved_fmt; + struct diff_flags saved_flags = revs->diffopt.flags; + + /* Always show if we're not in "follow" mode with a single file. */ + if (!ctx.qry.follow) + return 1; + + /* + * In "follow" mode, we don't show merges. This is consistent with + * "git log --follow -- <file>". + */ + if (parents && parents->next) + return 0; + + /* + * If this is the root commit, do what rev_info tells us. + */ + if (!parents) + return revs->show_root_diff; + + /* When we get here we have precisely one parent. */ + parent = parents->item; + /* If we can't parse the commit, let print_commit() report an error. */ + if (repo_parse_commit(the_repository, parent)) + return 1; + + files = 0; + add_lines = 0; + rem_lines = 0; + + revs->diffopt.flags.recursive = 1; + diff_tree_oid(get_commit_tree_oid(parent), + get_commit_tree_oid(commit), + "", &revs->diffopt); + diffcore_std(&revs->diffopt); + + found = !diff_queue_is_empty(&revs->diffopt); + saved_fmt = revs->diffopt.output_format; + revs->diffopt.output_format = DIFF_FORMAT_CALLBACK; + revs->diffopt.format_callback = cgit_diff_tree_cb; + revs->diffopt.format_callback_data = handle_rename; + diff_flush(&revs->diffopt); + revs->diffopt.output_format = saved_fmt; + revs->diffopt.flags = saved_flags; + + lines_counted = 1; + return found; +} + +static void print_commit(struct commit *commit, struct rev_info *revs) +{ + struct commitinfo *info; + int columns = revs->graph ? 4 : 3; + struct strbuf graphbuf = STRBUF_INIT; + struct strbuf msgbuf = STRBUF_INIT; + + if (ctx.repo->enable_log_filecount) + columns++; + if (ctx.repo->enable_log_linecount) + columns++; + + if (revs->graph) { + /* Advance graph until current commit */ + while (!graph_next_line(revs->graph, &graphbuf)) { + /* Print graph segment in otherwise empty table row */ + html("<tr class='nohover'><td class='commitgraph'>"); + html(graphbuf.buf); + htmlf("</td><td colspan='%d' /></tr>\n", columns); + strbuf_setlen(&graphbuf, 0); + } + /* Current commit's graph segment is now ready in graphbuf */ + } + + info = cgit_parse_commit(commit); + htmlf("<tr%s>", ctx.qry.showmsg ? " class='logheader'" : ""); + + if (revs->graph) { + /* Print graph segment for current commit */ + html("<td class='commitgraph'>"); + html(graphbuf.buf); + html("</td>"); + strbuf_setlen(&graphbuf, 0); + } + else { + html("<td>"); + cgit_print_age(info->committer_date, info->committer_tz, TM_WEEK * 2); + html("</td>"); + } + + htmlf("<td%s>", ctx.qry.showmsg ? " class='logsubject'" : ""); + if (ctx.qry.showmsg) { + /* line-wrap long commit subjects instead of truncating them */ + size_t subject_len = strlen(info->subject); + + if (subject_len > ctx.cfg.max_msg_len && + ctx.cfg.max_msg_len >= 15) { + /* symbol for signaling line-wrap (in PAGE_ENCODING) */ + const char wrap_symbol[] = { ' ', 0xE2, 0x86, 0xB5, 0 }; + int i = ctx.cfg.max_msg_len - strlen(wrap_symbol); + + /* Rewind i to preceding space character */ + while (i > 0 && !isspace(info->subject[i])) + --i; + if (!i) /* Oops, zero spaces. Reset i */ + i = ctx.cfg.max_msg_len - strlen(wrap_symbol); + + /* add remainder starting at i to msgbuf */ + strbuf_add(&msgbuf, info->subject + i, subject_len - i); + strbuf_trim(&msgbuf); + strbuf_add(&msgbuf, "\n\n", 2); + + /* Place wrap_symbol at position i in info->subject */ + strlcpy(info->subject + i, wrap_symbol, subject_len - i + 1); + } + } + show_commit_decorations(commit); + html(" "); + cgit_commit_link(info->subject, NULL, NULL, ctx.qry.head, + oid_to_hex(&commit->object.oid), ctx.qry.vpath); + html("</td><td>"); + cgit_open_filter(ctx.repo->email_filter, info->author_email, "log"); + html_txt(info->author); + cgit_close_filter(ctx.repo->email_filter); + + if (revs->graph) { + html("</td><td>"); + cgit_print_age(info->committer_date, info->committer_tz, TM_WEEK * 2); + } + + if (!lines_counted && (ctx.repo->enable_log_filecount || + ctx.repo->enable_log_linecount)) { + files = 0; + add_lines = 0; + rem_lines = 0; + cgit_diff_commit(commit, inspect_files, ctx.qry.vpath); + } + + if (ctx.repo->enable_log_filecount) + htmlf("</td><td>%d", files); + if (ctx.repo->enable_log_linecount) + htmlf("</td><td><span class='deletions'>-%d</span>/" + "<span class='insertions'>+%d</span>", rem_lines, add_lines); + + html("</td></tr>\n"); + + if ((revs->graph && !graph_is_commit_finished(revs->graph)) + || ctx.qry.showmsg) { /* Print a second table row */ + html("<tr class='nohover-highlight'>"); + + if (ctx.qry.showmsg) { + /* Concatenate commit message + notes in msgbuf */ + if (info->msg && *(info->msg)) { + strbuf_addstr(&msgbuf, info->msg); + strbuf_addch(&msgbuf, '\n'); + } + format_display_notes(&commit->object.oid, + &msgbuf, PAGE_ENCODING, 0); + strbuf_addch(&msgbuf, '\n'); + strbuf_ltrim(&msgbuf); + } + + if (revs->graph) { + int lines = 0; + + /* Calculate graph padding */ + if (ctx.qry.showmsg) { + /* Count #lines in commit message + notes */ + const char *p = msgbuf.buf; + lines = 1; + while ((p = strchr(p, '\n'))) { + p++; + lines++; + } + } + + /* Print graph padding */ + html("<td class='commitgraph'>"); + while (lines > 0 || !graph_is_commit_finished(revs->graph)) { + if (graphbuf.len) + html("\n"); + strbuf_setlen(&graphbuf, 0); + graph_next_line(revs->graph, &graphbuf); + html(graphbuf.buf); + lines--; + } + html("</td>\n"); + } + else + html("<td/>"); /* Empty 'Age' column */ + + /* Print msgbuf into remainder of table row */ + htmlf("<td colspan='%d'%s>\n", columns - (revs->graph ? 1 : 0), + ctx.qry.showmsg ? " class='logmsg'" : ""); + html_txt(msgbuf.buf); + html("</td></tr>\n"); + } + + strbuf_release(&msgbuf); + strbuf_release(&graphbuf); + cgit_free_commitinfo(info); +} + +static const char *disambiguate_ref(const char *ref, int *must_free_result) +{ + struct object_id oid; + struct strbuf longref = STRBUF_INIT; + + strbuf_addf(&longref, "refs/heads/%s", ref); + if (repo_get_oid(the_repository, longref.buf, &oid) == 0) { + *must_free_result = 1; + return strbuf_detach(&longref, NULL); + } + + *must_free_result = 0; + strbuf_release(&longref); + return ref; +} + +static char *next_token(char **src) +{ + char *result; + + if (!src || !*src) + return NULL; + while (isspace(**src)) + (*src)++; + if (!**src) + return NULL; + result = *src; + while (**src) { + if (isspace(**src)) { + **src = '\0'; + (*src)++; + break; + } + (*src)++; + } + return result; +} + +void cgit_print_log(const char *tip, int ofs, int cnt, char *grep, char *pattern, + const char *path, int pager, int commit_graph, int commit_sort) +{ + struct rev_info rev; + struct commit *commit; + struct strvec rev_argv = STRVEC_INIT; + int i, columns = commit_graph ? 4 : 3; + int must_free_tip = 0; + + /* rev_argv.argv[0] will be ignored by setup_revisions */ + strvec_push(&rev_argv, "log_rev_setup"); + + if (!tip) + tip = ctx.qry.head; + tip = disambiguate_ref(tip, &must_free_tip); + strvec_push(&rev_argv, tip); + + if (grep && pattern && *pattern) { + pattern = xstrdup(pattern); + if (!strcmp(grep, "grep") || !strcmp(grep, "author") || + !strcmp(grep, "committer")) { + strvec_pushf(&rev_argv, "--%s=%s", grep, pattern); + } else if (!strcmp(grep, "range")) { + char *arg; + /* Split the pattern at whitespace and add each token + * as a revision expression. Do not accept other + * rev-list options. Also, replace the previously + * pushed tip (it's no longer relevant). + */ + strvec_pop(&rev_argv); + while ((arg = next_token(&pattern))) { + if (*arg == '-') { + fprintf(stderr, "Bad range expr: %s\n", + arg); + break; + } + strvec_push(&rev_argv, arg); + } + } + } + + if (!path || !ctx.cfg.enable_follow_links) { + /* + * If we don't have a path, "follow" is a no-op so make sure + * the variable is set to false to avoid needing to check + * both this and whether we have a path everywhere. + */ + ctx.qry.follow = 0; + } + + if (commit_graph && !ctx.qry.follow) { + strvec_push(&rev_argv, "--graph"); + strvec_push(&rev_argv, "--color"); + graph_set_column_colors(column_colors_html, + COLUMN_COLORS_HTML_MAX); + } + + if (commit_sort == 1) + strvec_push(&rev_argv, "--date-order"); + else if (commit_sort == 2) + strvec_push(&rev_argv, "--topo-order"); + + if (path && ctx.qry.follow) + strvec_push(&rev_argv, "--follow"); + strvec_push(&rev_argv, "--"); + if (path) + strvec_push(&rev_argv, path); + + repo_init_revisions(the_repository, &rev, NULL); + rev.abbrev = DEFAULT_ABBREV; + rev.commit_format = CMIT_FMT_DEFAULT; + rev.verbose_header = 1; + rev.show_root_diff = 0; + rev.ignore_missing = 1; + rev.simplify_history = 1; + setup_revisions(rev_argv.nr, rev_argv.v, &rev, NULL); + load_ref_decorations(NULL, DECORATE_FULL_REFS); + rev.show_decorations = 1; + rev.grep_filter.ignore_case = 1; + + rev.diffopt.detect_rename = 1; + rev.diffopt.rename_limit = ctx.cfg.renamelimit; + if (ctx.qry.ignorews) + DIFF_XDL_SET(&rev.diffopt, IGNORE_WHITESPACE); + + compile_grep_patterns(&rev.grep_filter); + prepare_revision_walk(&rev); + + if (pager) { + cgit_print_layout_start(); + html("<table class='list nowrap'>"); + } + + html("<tr class='nohover'>"); + if (commit_graph) + html("<th></th>"); + else + html("<th class='left'>Age</th>"); + html("<th class='left'>Commit message"); + if (pager) { + html(" ("); + cgit_log_link(ctx.qry.showmsg ? "Collapse" : "Expand", NULL, + NULL, ctx.qry.head, ctx.qry.oid, + ctx.qry.vpath, ctx.qry.ofs, ctx.qry.grep, + ctx.qry.search, ctx.qry.showmsg ? 0 : 1, + ctx.qry.follow); + html(")"); + } + html("</th><th class='left'>Author</th>"); + if (rev.graph) + html("<th class='left'>Age</th>"); + if (ctx.repo->enable_log_filecount) { + html("<th class='left'>Files</th>"); + columns++; + } + if (ctx.repo->enable_log_linecount) { + html("<th class='left'>Lines</th>"); + columns++; + } + html("</tr>\n"); + + if (ofs<0) + ofs = 0; + + for (i = 0; i < ofs && (commit = get_revision(&rev)) != NULL; /* nop */) { + if (show_commit(commit, &rev)) + i++; + release_commit_memory(the_repository->parsed_objects, commit); + commit->parents = NULL; + } + + for (i = 0; i < cnt && (commit = get_revision(&rev)) != NULL; /* nop */) { + /* + * In "follow" mode, we must count the files and lines the + * first time we invoke diff on a given commit, and we need + * to do that to see if the commit touches the path we care + * about, so we do it in show_commit. Hence we must clear + * lines_counted here. + * + * This has the side effect of avoiding running diff twice + * when we are both following renames and showing file + * and/or line counts. + */ + lines_counted = 0; + if (show_commit(commit, &rev)) { + i++; + print_commit(commit, &rev); + } + release_commit_memory(the_repository->parsed_objects, commit); + commit->parents = NULL; + } + if (pager) { + html("</table><ul class='pager'>"); + if (ofs > 0) { + html("<li>"); + cgit_log_link("[prev]", NULL, NULL, ctx.qry.head, + ctx.qry.oid, ctx.qry.vpath, + ofs - cnt, ctx.qry.grep, + ctx.qry.search, ctx.qry.showmsg, + ctx.qry.follow); + html("</li>"); + } + if ((commit = get_revision(&rev)) != NULL) { + html("<li>"); + cgit_log_link("[next]", NULL, NULL, ctx.qry.head, + ctx.qry.oid, ctx.qry.vpath, + ofs + cnt, ctx.qry.grep, + ctx.qry.search, ctx.qry.showmsg, + ctx.qry.follow); + html("</li>"); + } + html("</ul>"); + cgit_print_layout_end(); + } else if ((commit = get_revision(&rev)) != NULL) { + htmlf("<tr class='nohover'><td colspan='%d'>", columns); + cgit_log_link("[...]", NULL, NULL, ctx.qry.head, NULL, + ctx.qry.vpath, 0, NULL, NULL, ctx.qry.showmsg, + ctx.qry.follow); + html("</td></tr>\n"); + } + + /* If we allocated tip then it is safe to cast away const. */ + if (must_free_tip) + free((char*) tip); +} diff --git a/third_party/cgit/ui-log.h b/third_party/cgit/ui-log.h new file mode 100644 index 0000000000..325607cdab --- /dev/null +++ b/third_party/cgit/ui-log.h @@ -0,0 +1,9 @@ +#ifndef UI_LOG_H +#define UI_LOG_H + +extern void cgit_print_log(const char *tip, int ofs, int cnt, char *grep, + char *pattern, const char *path, int pager, + int commit_graph, int commit_sort); +extern void show_commit_decorations(struct commit *commit); + +#endif /* UI_LOG_H */ diff --git a/third_party/cgit/ui-patch.c b/third_party/cgit/ui-patch.c new file mode 100644 index 0000000000..3819a8152a --- /dev/null +++ b/third_party/cgit/ui-patch.c @@ -0,0 +1,98 @@ +/* ui-patch.c: generate patch view + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "ui-patch.h" +#include "html.h" +#include "ui-shared.h" + +/* two commit hashes with two dots in between and termination */ +#define REV_RANGE_LEN 2 * GIT_MAX_HEXSZ + 3 + +void cgit_print_patch(const char *new_rev, const char *old_rev, + const char *prefix) +{ + struct rev_info rev; + struct commit *commit; + struct object_id new_rev_oid, old_rev_oid; + char rev_range[REV_RANGE_LEN]; + const char *rev_argv[] = { NULL, "--reverse", "--format=email", rev_range, "--", prefix, NULL }; + int rev_argc = ARRAY_SIZE(rev_argv) - 1; + char *patchname; + + if (!prefix) + rev_argc--; + + if (!new_rev) + new_rev = ctx.qry.head; + + if (repo_get_oid(the_repository, new_rev, &new_rev_oid)) { + cgit_print_error_page(404, "Not found", + "Bad object id: %s", new_rev); + return; + } + commit = lookup_commit_reference(the_repository, &new_rev_oid); + if (!commit) { + cgit_print_error_page(404, "Not found", + "Bad commit reference: %s", new_rev); + return; + } + + if (old_rev) { + if (repo_get_oid(the_repository, old_rev, &old_rev_oid)) { + cgit_print_error_page(404, "Not found", + "Bad object id: %s", old_rev); + return; + } + if (!lookup_commit_reference(the_repository, &old_rev_oid)) { + cgit_print_error_page(404, "Not found", + "Bad commit reference: %s", old_rev); + return; + } + } else if (commit->parents && commit->parents->item) { + oidcpy(&old_rev_oid, &commit->parents->item->object.oid); + } else { + oidclr(&old_rev_oid); + } + + if (is_null_oid(&old_rev_oid)) { + memcpy(rev_range, oid_to_hex(&new_rev_oid), the_hash_algo->hexsz + 1); + } else { + xsnprintf(rev_range, REV_RANGE_LEN, "%s..%s", oid_to_hex(&old_rev_oid), + oid_to_hex(&new_rev_oid)); + } + + patchname = fmt("%s.patch", rev_range); + ctx.page.mimetype = "text/plain"; + ctx.page.filename = patchname; + cgit_print_http_headers(); + + if (ctx.cfg.noplainemail) { + rev_argv[2] = "--format=format:From %H Mon Sep 17 00:00:00 " + "2001%nFrom: %an%nDate: %aD%n%w(78,0,1)Subject: " + "%s%n%n%w(0)%b"; + } + + repo_init_revisions(the_repository, &rev, NULL); + rev.abbrev = DEFAULT_ABBREV; + rev.verbose_header = 1; + rev.diff = 1; + rev.show_root_diff = 1; + rev.max_parents = 1; + rev.diffopt.output_format |= DIFF_FORMAT_DIFFSTAT | + DIFF_FORMAT_PATCH | DIFF_FORMAT_SUMMARY; + if (prefix) + rev.diffopt.stat_sep = fmt("(limited to '%s')\n\n", prefix); + setup_revisions(rev_argc, rev_argv, &rev, NULL); + prepare_revision_walk(&rev); + + while ((commit = get_revision(&rev)) != NULL) { + log_tree_commit(&rev, commit); + printf("-- \ncgit %s\n\n", cgit_version); + } +} diff --git a/third_party/cgit/ui-patch.h b/third_party/cgit/ui-patch.h new file mode 100644 index 0000000000..7a6cacd5ac --- /dev/null +++ b/third_party/cgit/ui-patch.h @@ -0,0 +1,7 @@ +#ifndef UI_PATCH_H +#define UI_PATCH_H + +extern void cgit_print_patch(const char *new_rev, const char *old_rev, + const char *prefix); + +#endif /* UI_PATCH_H */ diff --git a/third_party/cgit/ui-plain.c b/third_party/cgit/ui-plain.c new file mode 100644 index 0000000000..a66c5a1de0 --- /dev/null +++ b/third_party/cgit/ui-plain.c @@ -0,0 +1,207 @@ +/* ui-plain.c: functions for output of plain blobs by path + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "ui-plain.h" +#include "html.h" +#include "ui-shared.h" + +struct walk_tree_context { + int match_baselen; + int match; +}; + +static int print_object(const struct object_id *oid, const char *path) +{ + enum object_type type; + char *buf, *mimetype; + unsigned long size; + + type = oid_object_info(the_repository, oid, &size); + if (type == OBJ_BAD) { + cgit_print_error_page(404, "Not found", "Not found"); + return 0; + } + + buf = repo_read_object_file(the_repository, oid, &type, &size); + if (!buf) { + cgit_print_error_page(404, "Not found", "Not found"); + return 0; + } + + mimetype = get_mimetype_for_filename(path); + ctx.page.mimetype = mimetype; + + if (!ctx.repo->enable_html_serving) { + html("X-Content-Type-Options: nosniff\n"); + html("Content-Security-Policy: default-src 'none'\n"); + if (mimetype) { + /* Built-in white list allows PDF and everything that isn't text/ and application/ */ + if ((!strncmp(mimetype, "text/", 5) || !strncmp(mimetype, "application/", 12)) && strcmp(mimetype, "application/pdf")) + ctx.page.mimetype = NULL; + } + } + + if (!ctx.page.mimetype) { + if (buffer_is_binary(buf, size)) { + ctx.page.mimetype = "application/octet-stream"; + ctx.page.charset = NULL; + } else { + ctx.page.mimetype = "text/plain"; + } + } + ctx.page.filename = path; + ctx.page.size = size; + ctx.page.etag = oid_to_hex(oid); + cgit_print_http_headers(); + html_raw(buf, size); + free(mimetype); + free(buf); + return 1; +} + +static char *buildpath(const char *base, int baselen, const char *path) +{ + if (path[0]) + return fmtalloc("%.*s%s/", baselen, base, path); + else + return fmtalloc("%.*s/", baselen, base); +} + +static void print_dir(const struct object_id *oid, const char *base, + int baselen, const char *path) +{ + char *fullpath, *slash; + size_t len; + + fullpath = buildpath(base, baselen, path); + slash = (fullpath[0] == '/' ? "" : "/"); + ctx.page.etag = oid_to_hex(oid); + cgit_print_http_headers(); + htmlf("<html><head><title>%s", slash); + html_txt(fullpath); + htmlf("</title></head>\n<body>\n<h2>%s", slash); + html_txt(fullpath); + html("</h2>\n<ul>\n"); + len = strlen(fullpath); + if (len > 1) { + fullpath[len - 1] = 0; + slash = strrchr(fullpath, '/'); + if (slash) + *(slash + 1) = 0; + else { + free(fullpath); + fullpath = NULL; + } + html("<li>"); + cgit_plain_link("../", NULL, NULL, ctx.qry.head, ctx.qry.oid, + fullpath); + html("</li>\n"); + } + free(fullpath); +} + +static void print_dir_entry(const struct object_id *oid, const char *base, + int baselen, const char *path, unsigned mode) +{ + char *fullpath; + + fullpath = buildpath(base, baselen, path); + if (!S_ISDIR(mode) && !S_ISGITLINK(mode)) + fullpath[strlen(fullpath) - 1] = 0; + html(" <li>"); + if (S_ISGITLINK(mode)) { + cgit_submodule_link(NULL, fullpath, oid_to_hex(oid)); + } else + cgit_plain_link(path, NULL, NULL, ctx.qry.head, ctx.qry.oid, + fullpath); + html("</li>\n"); + free(fullpath); +} + +static void print_dir_tail(void) +{ + html(" </ul>\n</body></html>\n"); +} + +static int walk_tree(const struct object_id *oid, struct strbuf *base, + const char *pathname, unsigned mode, void *cbdata) +{ + struct walk_tree_context *walk_tree_ctx = cbdata; + + if (base->len == walk_tree_ctx->match_baselen) { + if (S_ISREG(mode) || S_ISLNK(mode)) { + if (print_object(oid, pathname)) + walk_tree_ctx->match = 1; + } else if (S_ISDIR(mode)) { + print_dir(oid, base->buf, base->len, pathname); + walk_tree_ctx->match = 2; + return READ_TREE_RECURSIVE; + } + } else if (base->len < INT_MAX && (int)base->len > walk_tree_ctx->match_baselen) { + print_dir_entry(oid, base->buf, base->len, pathname, mode); + walk_tree_ctx->match = 2; + } else if (S_ISDIR(mode)) { + return READ_TREE_RECURSIVE; + } + + return 0; +} + +static int basedir_len(const char *path) +{ + char *p = strrchr(path, '/'); + if (p) + return p - path + 1; + return 0; +} + +void cgit_print_plain(void) +{ + const char *rev = ctx.qry.oid; + struct object_id oid; + struct commit *commit; + struct pathspec_item path_items = { + .match = ctx.qry.path, + .len = ctx.qry.path ? strlen(ctx.qry.path) : 0 + }; + struct pathspec paths = { + .nr = 1, + .items = &path_items + }; + struct walk_tree_context walk_tree_ctx = { + .match = 0 + }; + + if (!rev) + rev = ctx.qry.head; + + if (repo_get_oid(the_repository, rev, &oid)) { + cgit_print_error_page(404, "Not found", "Not found"); + return; + } + commit = lookup_commit_reference(the_repository, &oid); + if (!commit || repo_parse_commit(the_repository, commit)) { + cgit_print_error_page(404, "Not found", "Not found"); + return; + } + if (!path_items.match) { + path_items.match = ""; + walk_tree_ctx.match_baselen = -1; + print_dir(get_commit_tree_oid(commit), "", 0, ""); + walk_tree_ctx.match = 2; + } + else + walk_tree_ctx.match_baselen = basedir_len(path_items.match); + read_tree(the_repository, repo_get_commit_tree(the_repository, commit), + &paths, walk_tree, &walk_tree_ctx); + if (!walk_tree_ctx.match) + cgit_print_error_page(404, "Not found", "Not found"); + else if (walk_tree_ctx.match == 2) + print_dir_tail(); +} diff --git a/third_party/cgit/ui-plain.h b/third_party/cgit/ui-plain.h new file mode 100644 index 0000000000..5bff07b83b --- /dev/null +++ b/third_party/cgit/ui-plain.h @@ -0,0 +1,6 @@ +#ifndef UI_PLAIN_H +#define UI_PLAIN_H + +extern void cgit_print_plain(void); + +#endif /* UI_PLAIN_H */ diff --git a/third_party/cgit/ui-refs.c b/third_party/cgit/ui-refs.c new file mode 100644 index 0000000000..456f610df4 --- /dev/null +++ b/third_party/cgit/ui-refs.c @@ -0,0 +1,219 @@ +/* ui-refs.c: browse symbolic refs + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "ui-refs.h" +#include "html.h" +#include "ui-shared.h" + +static inline int cmp_age(int age1, int age2) +{ + /* age1 and age2 are assumed to be non-negative */ + return age2 - age1; +} + +static int cmp_ref_name(const void *a, const void *b) +{ + struct refinfo *r1 = *(struct refinfo **)a; + struct refinfo *r2 = *(struct refinfo **)b; + + return strcmp(r1->refname, r2->refname); +} + +static int cmp_branch_age(const void *a, const void *b) +{ + struct refinfo *r1 = *(struct refinfo **)a; + struct refinfo *r2 = *(struct refinfo **)b; + + return cmp_age(r1->commit->committer_date, r2->commit->committer_date); +} + +static int get_ref_age(struct refinfo *ref) +{ + if (!ref->object) + return 0; + switch (ref->object->type) { + case OBJ_TAG: + return ref->tag ? ref->tag->tagger_date : 0; + case OBJ_COMMIT: + return ref->commit ? ref->commit->committer_date : 0; + } + return 0; +} + +static int cmp_tag_age(const void *a, const void *b) +{ + struct refinfo *r1 = *(struct refinfo **)a; + struct refinfo *r2 = *(struct refinfo **)b; + + return cmp_age(get_ref_age(r1), get_ref_age(r2)); +} + +static int print_branch(struct refinfo *ref) +{ + struct commitinfo *info = ref->commit; + char *name = (char *)ref->refname; + + if (!info) + return 1; + html("<tr><td>"); + cgit_log_link(name, NULL, NULL, name, NULL, NULL, 0, NULL, NULL, + ctx.qry.showmsg, 0); + html("</td><td>"); + + if (ref->object->type == OBJ_COMMIT) { + cgit_commit_link(info->subject, NULL, NULL, name, NULL, NULL); + html("</td><td>"); + cgit_open_filter(ctx.repo->email_filter, info->author_email, "refs"); + html_txt(info->author); + cgit_close_filter(ctx.repo->email_filter); + html("</td><td colspan='2'>"); + cgit_print_age(info->committer_date, info->committer_tz, -1); + } else { + html("</td><td></td><td>"); + cgit_object_link(ref->object); + } + html("</td></tr>\n"); + return 0; +} + +static void print_tag_header(void) +{ + html("<tr class='nohover'><th class='left'>Tag</th>" + "<th class='left'>Download</th>" + "<th class='left'>Author</th>" + "<th class='left' colspan='2'>Age</th></tr>\n"); +} + +static int print_tag(struct refinfo *ref) +{ + struct tag *tag = NULL; + struct taginfo *info = NULL; + char *name = (char *)ref->refname; + struct object *obj = ref->object; + + if (obj->type == OBJ_TAG) { + tag = (struct tag *)obj; + obj = tag->tagged; + info = ref->tag; + if (!info) + return 1; + } + + html("<tr><td>"); + cgit_tag_link(name, NULL, NULL, name); + html("</td><td>"); + if (ctx.repo->snapshots && (obj->type == OBJ_COMMIT)) + cgit_print_snapshot_links(ctx.repo, name, " "); + else + cgit_object_link(obj); + html("</td><td>"); + if (info) { + if (info->tagger) { + cgit_open_filter(ctx.repo->email_filter, info->tagger_email, "refs"); + html_txt(info->tagger); + cgit_close_filter(ctx.repo->email_filter); + } + } else if (ref->object->type == OBJ_COMMIT) { + cgit_open_filter(ctx.repo->email_filter, ref->commit->author_email, "refs"); + html_txt(ref->commit->author); + cgit_close_filter(ctx.repo->email_filter); + } + html("</td><td colspan='2'>"); + if (info) { + if (info->tagger_date > 0) + cgit_print_age(info->tagger_date, info->tagger_tz, -1); + } else if (ref->object->type == OBJ_COMMIT) { + cgit_print_age(ref->commit->commit->date, 0, -1); + } + html("</td></tr>\n"); + + return 0; +} + +static void print_refs_link(const char *path) +{ + html("<tr class='nohover'><td colspan='5'>"); + cgit_refs_link("[...]", NULL, NULL, ctx.qry.head, NULL, path); + html("</td></tr>"); +} + +void cgit_print_branches(int maxcount) +{ + struct reflist list; + int i; + + html("<tr class='nohover'><th class='left'>Branch</th>" + "<th class='left'>Commit message</th>" + "<th class='left'>Author</th>" + "<th class='left' colspan='2'>Age</th></tr>\n"); + + list.refs = NULL; + list.alloc = list.count = 0; + for_each_branch_ref(cgit_refs_cb, &list); + if (ctx.repo->enable_remote_branches) + for_each_remote_ref(cgit_refs_cb, &list); + + if (maxcount == 0 || maxcount > list.count) + maxcount = list.count; + + qsort(list.refs, list.count, sizeof(*list.refs), cmp_branch_age); + if (ctx.repo->branch_sort == 0) + qsort(list.refs, maxcount, sizeof(*list.refs), cmp_ref_name); + + for (i = 0; i < maxcount; i++) + print_branch(list.refs[i]); + + if (maxcount < list.count) + print_refs_link("heads"); + + cgit_free_reflist_inner(&list); +} + +void cgit_print_tags(int maxcount) +{ + struct reflist list; + int i; + + list.refs = NULL; + list.alloc = list.count = 0; + for_each_tag_ref(cgit_refs_cb, &list); + if (list.count == 0) + return; + qsort(list.refs, list.count, sizeof(*list.refs), cmp_tag_age); + if (!maxcount) + maxcount = list.count; + else if (maxcount > list.count) + maxcount = list.count; + print_tag_header(); + for (i = 0; i < maxcount; i++) + print_tag(list.refs[i]); + + if (maxcount < list.count) + print_refs_link("tags"); + + cgit_free_reflist_inner(&list); +} + +void cgit_print_refs(void) +{ + cgit_print_layout_start(); + html("<table class='list nowrap'>"); + + if (ctx.qry.path && starts_with(ctx.qry.path, "heads")) + cgit_print_branches(0); + else if (ctx.qry.path && starts_with(ctx.qry.path, "tags")) + cgit_print_tags(0); + else { + cgit_print_branches(0); + html("<tr class='nohover'><td colspan='5'> </td></tr>"); + cgit_print_tags(0); + } + html("</table>"); + cgit_print_layout_end(); +} diff --git a/third_party/cgit/ui-refs.h b/third_party/cgit/ui-refs.h new file mode 100644 index 0000000000..1d4a54a2c8 --- /dev/null +++ b/third_party/cgit/ui-refs.h @@ -0,0 +1,8 @@ +#ifndef UI_REFS_H +#define UI_REFS_H + +extern void cgit_print_branches(int maxcount); +extern void cgit_print_tags(int maxcount); +extern void cgit_print_refs(void); + +#endif /* UI_REFS_H */ diff --git a/third_party/cgit/ui-repolist.c b/third_party/cgit/ui-repolist.c new file mode 100644 index 0000000000..97b11c5f16 --- /dev/null +++ b/third_party/cgit/ui-repolist.c @@ -0,0 +1,381 @@ +/* ui-repolist.c: functions for generating the repolist page + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "ui-repolist.h" +#include "html.h" +#include "ui-shared.h" + +static time_t read_agefile(const char *path) +{ + time_t result; + size_t size; + char *buf = NULL; + struct strbuf date_buf = STRBUF_INIT; + + if (readfile(path, &buf, &size)) { + free(buf); + return 0; + } + + if (parse_date(buf, &date_buf) == 0) + result = strtoul(date_buf.buf, NULL, 10); + else + result = 0; + free(buf); + strbuf_release(&date_buf); + return result; +} + +static int get_repo_modtime(const struct cgit_repo *repo, time_t *mtime) +{ + struct strbuf path = STRBUF_INIT; + struct stat s; + struct cgit_repo *r = (struct cgit_repo *)repo; + + if (repo->mtime != -1) { + *mtime = repo->mtime; + return 1; + } + strbuf_addf(&path, "%s/%s", repo->path, ctx.cfg.agefile); + if (stat(path.buf, &s) == 0) { + *mtime = read_agefile(path.buf); + if (*mtime) { + r->mtime = *mtime; + goto end; + } + } + + strbuf_reset(&path); + strbuf_addf(&path, "%s/refs/heads/%s", repo->path, + repo->defbranch ? repo->defbranch : "master"); + if (stat(path.buf, &s) == 0) { + *mtime = s.st_mtime; + r->mtime = *mtime; + goto end; + } + + strbuf_reset(&path); + strbuf_addf(&path, "%s/%s", repo->path, "packed-refs"); + if (stat(path.buf, &s) == 0) { + *mtime = s.st_mtime; + r->mtime = *mtime; + goto end; + } + + *mtime = 0; + r->mtime = *mtime; +end: + strbuf_release(&path); + return (r->mtime != 0); +} + +static void print_modtime(struct cgit_repo *repo) +{ + time_t t; + if (get_repo_modtime(repo, &t)) + cgit_print_age(t, 0, -1); +} + +static int is_match(struct cgit_repo *repo) +{ + if (!ctx.qry.search) + return 1; + if (repo->url && strcasestr(repo->url, ctx.qry.search)) + return 1; + if (repo->name && strcasestr(repo->name, ctx.qry.search)) + return 1; + if (repo->desc && strcasestr(repo->desc, ctx.qry.search)) + return 1; + if (repo->owner && strcasestr(repo->owner, ctx.qry.search)) + return 1; + return 0; +} + +static int is_in_url(struct cgit_repo *repo) +{ + if (!ctx.qry.url) + return 1; + if (repo->url && starts_with(repo->url, ctx.qry.url)) + return 1; + return 0; +} + +static int is_visible(struct cgit_repo *repo) +{ + if (repo->hide || repo->ignore) + return 0; + if (!(is_match(repo) && is_in_url(repo))) + return 0; + return 1; +} + +static int any_repos_visible(void) +{ + int i; + + for (i = 0; i < cgit_repolist.count; i++) { + if (is_visible(&cgit_repolist.repos[i])) + return 1; + } + return 0; +} + +static void print_sort_header(const char *title, const char *sort) +{ + char *currenturl = cgit_currenturl(); + html("<th class='left'><a href='"); + html_attr(currenturl); + htmlf("?s=%s", sort); + if (ctx.qry.search) { + html("&q="); + html_url_arg(ctx.qry.search); + } + htmlf("'>%s</a></th>", title); + free(currenturl); +} + +static void print_header(void) +{ + html("<tr class='nohover'>"); + print_sort_header("Name", "name"); + print_sort_header("Description", "desc"); + if (ctx.cfg.enable_index_owner) + print_sort_header("Owner", "owner"); + print_sort_header("Idle", "idle"); + if (ctx.cfg.enable_index_links) + html("<th class='left'>Links</th>"); + html("</tr>\n"); +} + + +static void print_pager(int items, int pagelen, char *search, char *sort) +{ + int i, ofs; + char *class = NULL; + html("<ul class='pager'>"); + for (i = 0, ofs = 0; ofs < items; i++, ofs = i * pagelen) { + class = (ctx.qry.ofs == ofs) ? "current" : NULL; + html("<li>"); + cgit_index_link(fmt("[%d]", i + 1), fmt("Page %d", i + 1), + class, search, sort, ofs, 0); + html("</li>"); + } + html("</ul>"); +} + +static int cmp(const char *s1, const char *s2) +{ + if (s1 && s2) { + if (ctx.cfg.case_sensitive_sort) + return strcmp(s1, s2); + else + return strcasecmp(s1, s2); + } + if (s1 && !s2) + return -1; + if (s2 && !s1) + return 1; + return 0; +} + +static int sort_name(const void *a, const void *b) +{ + const struct cgit_repo *r1 = a; + const struct cgit_repo *r2 = b; + + return cmp(r1->name, r2->name); +} + +static int sort_desc(const void *a, const void *b) +{ + const struct cgit_repo *r1 = a; + const struct cgit_repo *r2 = b; + + return cmp(r1->desc, r2->desc); +} + +static int sort_owner(const void *a, const void *b) +{ + const struct cgit_repo *r1 = a; + const struct cgit_repo *r2 = b; + + return cmp(r1->owner, r2->owner); +} + +static int sort_idle(const void *a, const void *b) +{ + const struct cgit_repo *r1 = a; + const struct cgit_repo *r2 = b; + time_t t1, t2; + + t1 = t2 = 0; + get_repo_modtime(r1, &t1); + get_repo_modtime(r2, &t2); + return t2 - t1; +} + +static int sort_section(const void *a, const void *b) +{ + const struct cgit_repo *r1 = a; + const struct cgit_repo *r2 = b; + int result; + + result = cmp(r1->section, r2->section); + if (!result) { + if (!strcmp(ctx.cfg.repository_sort, "age")) + result = sort_idle(r1, r2); + if (!result) + result = cmp(r1->name, r2->name); + } + return result; +} + +struct sortcolumn { + const char *name; + int (*fn)(const void *a, const void *b); +}; + +static const struct sortcolumn sortcolumn[] = { + {"section", sort_section}, + {"name", sort_name}, + {"desc", sort_desc}, + {"owner", sort_owner}, + {"idle", sort_idle}, + {NULL, NULL} +}; + +static int sort_repolist(char *field) +{ + const struct sortcolumn *column; + + for (column = &sortcolumn[0]; column->name; column++) { + if (strcmp(field, column->name)) + continue; + qsort(cgit_repolist.repos, cgit_repolist.count, + sizeof(struct cgit_repo), column->fn); + return 1; + } + return 0; +} + + +void cgit_print_repolist(void) +{ + int i, columns = 3, hits = 0, header = 0; + char *last_section = NULL; + char *section; + char *repourl; + int sorted = 0; + + if (!any_repos_visible()) { + cgit_print_error_page(404, "Not found", "No repositories found"); + return; + } + + if (ctx.cfg.enable_index_links) + ++columns; + if (ctx.cfg.enable_index_owner) + ++columns; + + ctx.page.title = ctx.cfg.root_title; + cgit_print_http_headers(); + cgit_print_docstart(); + cgit_print_pageheader(); + + if (ctx.qry.sort) + sorted = sort_repolist(ctx.qry.sort); + else if (ctx.cfg.section_sort) + sort_repolist("section"); + + html("<table summary='repository list' class='list nowrap'>"); + for (i = 0; i < cgit_repolist.count; i++) { + ctx.repo = &cgit_repolist.repos[i]; + if (!is_visible(ctx.repo)) + continue; + hits++; + if (hits <= ctx.qry.ofs) + continue; + if (hits > ctx.qry.ofs + ctx.cfg.max_repo_count) + continue; + if (!header++) + print_header(); + section = ctx.repo->section; + if (section && !strcmp(section, "")) + section = NULL; + if (!sorted && + ((last_section == NULL && section != NULL) || + (last_section != NULL && section == NULL) || + (last_section != NULL && section != NULL && + strcmp(section, last_section)))) { + htmlf("<tr class='nohover-highlight'><td colspan='%d' class='reposection'>", + columns); + html_txt(section); + html("</td></tr>"); + last_section = section; + } + htmlf("<tr><td class='%s'>", + !sorted && section ? "sublevel-repo" : "toplevel-repo"); + cgit_summary_link(ctx.repo->name, NULL, NULL, NULL); + html("</td><td>"); + repourl = cgit_repourl(ctx.repo->url); + html_link_open(repourl, NULL, NULL); + free(repourl); + if (html_ntxt(ctx.repo->desc, ctx.cfg.max_repodesc_len) < 0) + html("..."); + html_link_close(); + html("</td><td>"); + if (ctx.cfg.enable_index_owner) { + if (ctx.repo->owner_filter) { + cgit_open_filter(ctx.repo->owner_filter); + html_txt(ctx.repo->owner); + cgit_close_filter(ctx.repo->owner_filter); + } else { + char *currenturl = cgit_currenturl(); + html("<a href='"); + html_attr(currenturl); + html("?q="); + html_url_arg(ctx.repo->owner); + html("'>"); + html_txt(ctx.repo->owner); + html("</a>"); + free(currenturl); + } + html("</td><td>"); + } + print_modtime(ctx.repo); + html("</td>"); + if (ctx.cfg.enable_index_links) { + html("<td>"); + cgit_summary_link("summary", NULL, "button", NULL); + html(" "); + cgit_log_link("log", NULL, "button", NULL, NULL, NULL, + 0, NULL, NULL, ctx.qry.showmsg, 0); + html(" "); + cgit_tree_link("tree", NULL, "button", NULL, NULL, NULL); + html("</td>"); + } + html("</tr>\n"); + } + html("</table>"); + if (hits > ctx.cfg.max_repo_count) + print_pager(hits, ctx.cfg.max_repo_count, ctx.qry.search, ctx.qry.sort); + cgit_print_docend(); +} + +void cgit_print_site_readme(void) +{ + cgit_print_layout_start(); + if (!ctx.cfg.root_readme) + goto done; + cgit_open_filter(ctx.cfg.about_filter, ctx.cfg.root_readme); + html_include(ctx.cfg.root_readme); + cgit_close_filter(ctx.cfg.about_filter); +done: + cgit_print_layout_end(); +} diff --git a/third_party/cgit/ui-repolist.h b/third_party/cgit/ui-repolist.h new file mode 100644 index 0000000000..1b6b3227db --- /dev/null +++ b/third_party/cgit/ui-repolist.h @@ -0,0 +1,7 @@ +#ifndef UI_REPOLIST_H +#define UI_REPOLIST_H + +extern void cgit_print_repolist(void); +extern void cgit_print_site_readme(void); + +#endif /* UI_REPOLIST_H */ diff --git a/third_party/cgit/ui-shared.c b/third_party/cgit/ui-shared.c new file mode 100644 index 0000000000..d047f9a131 --- /dev/null +++ b/third_party/cgit/ui-shared.c @@ -0,0 +1,1239 @@ +/* ui-shared.c: common web output functions + * + * Copyright (C) 2006-2017 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "ui-shared.h" +#include "cmd.h" +#include "html.h" +#include "version.h" + +static const char cgit_doctype[] = +"<!DOCTYPE html>\n"; + +static char *http_date(time_t t) +{ + static char day[][4] = + {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; + static char month[][4] = + {"Jan", "Feb", "Mar", "Apr", "May", "Jun", + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; + struct tm tm; + gmtime_r(&t, &tm); + return fmt("%s, %02d %s %04d %02d:%02d:%02d GMT", day[tm.tm_wday], + tm.tm_mday, month[tm.tm_mon], 1900 + tm.tm_year, + tm.tm_hour, tm.tm_min, tm.tm_sec); +} + +void cgit_print_error(const char *fmt, ...) +{ + va_list ap; + va_start(ap, fmt); + cgit_vprint_error(fmt, ap); + va_end(ap); +} + +void cgit_vprint_error(const char *fmt, va_list ap) +{ + va_list cp; + html("<div class='error'>"); + va_copy(cp, ap); + html_vtxtf(fmt, cp); + va_end(cp); + html("</div>\n"); +} + +const char *cgit_httpscheme(void) +{ + if (ctx.env.https && !strcmp(ctx.env.https, "on")) + return "https://"; + else + return "http://"; +} + +char *cgit_hosturl(void) +{ + if (ctx.env.http_host) + return xstrdup(ctx.env.http_host); + if (!ctx.env.server_name) + return NULL; + if (!ctx.env.server_port || atoi(ctx.env.server_port) == 80) + return xstrdup(ctx.env.server_name); + return fmtalloc("%s:%s", ctx.env.server_name, ctx.env.server_port); +} + +char *cgit_currenturl(void) +{ + const char *root = cgit_rooturl(); + + if (!ctx.qry.url) + return xstrdup(root); + if (root[0] && root[strlen(root) - 1] == '/') + return fmtalloc("%s%s", root, ctx.qry.url); + return fmtalloc("%s/%s", root, ctx.qry.url); +} + +char *cgit_currentfullurl(void) +{ + const char *root = cgit_rooturl(); + const char *orig_query = ctx.env.query_string ? ctx.env.query_string : ""; + size_t len = strlen(orig_query); + char *query = xmalloc(len + 2), *start_url, *ret; + + /* Remove all url=... parts from query string */ + memcpy(query + 1, orig_query, len + 1); + query[0] = '?'; + start_url = query; + while ((start_url = strstr(start_url, "url=")) != NULL) { + if (start_url[-1] == '?' || start_url[-1] == '&') { + const char *end_url = strchr(start_url, '&'); + if (end_url) + memmove(start_url, end_url + 1, strlen(end_url)); + else + start_url[0] = '\0'; + } else + ++start_url; + } + if (!query[1]) + query[0] = '\0'; + + if (!ctx.qry.url) + ret = fmtalloc("%s%s", root, query); + else if (root[0] && root[strlen(root) - 1] == '/') + ret = fmtalloc("%s%s%s", root, ctx.qry.url, query); + else + ret = fmtalloc("%s/%s%s", root, ctx.qry.url, query); + free(query); + return ret; +} + +const char *cgit_rooturl(void) +{ + if (ctx.cfg.virtual_root) + return ctx.cfg.virtual_root; + else + return ctx.cfg.script_name; +} + +const char *cgit_loginurl(void) +{ + static const char *login_url; + if (!login_url) + login_url = fmtalloc("%s?p=login", cgit_rooturl()); + return login_url; +} + +char *cgit_repourl(const char *reponame) +{ + // my cgit instance *only* serves the depot, hence that's the only value ever + // needed. + return fmtalloc("/"); +} + +char *cgit_fileurl(const char *reponame, const char *pagename, + const char *filename, const char *query) +{ + struct strbuf sb = STRBUF_INIT; + + strbuf_addf(&sb, "%s%s/%s", ctx.cfg.virtual_root, + pagename, (filename ? filename:"")); + + if (query) { + strbuf_addf(&sb, "%s%s", "?", query); + } + + return strbuf_detach(&sb, NULL); +} + +char *cgit_pageurl(const char *reponame, const char *pagename, + const char *query) +{ + return cgit_fileurl(reponame, pagename, NULL, query); +} + +const char *cgit_repobasename(const char *reponame) +{ + /* I assume we don't need to store more than one repo basename */ + static char rvbuf[1024]; + int p; + const char *rv; + size_t len; + + len = strlcpy(rvbuf, reponame, sizeof(rvbuf)); + if (len >= sizeof(rvbuf)) + die("cgit_repobasename: truncated repository name '%s'", reponame); + p = len - 1; + /* strip trailing slashes */ + while (p && rvbuf[p] == '/') + rvbuf[p--] = '\0'; + /* strip trailing .git */ + if (p >= 3 && starts_with(&rvbuf[p-3], ".git")) { + p -= 3; + rvbuf[p--] = '\0'; + } + /* strip more trailing slashes if any */ + while (p && rvbuf[p] == '/') + rvbuf[p--] = '\0'; + /* find last slash in the remaining string */ + rv = strrchr(rvbuf, '/'); + if (rv) + return ++rv; + return rvbuf; +} + +const char *cgit_snapshot_prefix(const struct cgit_repo *repo) +{ + if (repo->snapshot_prefix) + return repo->snapshot_prefix; + + return cgit_repobasename(repo->url); +} + +static void site_url(const char *page, const char *search, const char *sort, int ofs, int always_root) +{ + char *delim = "?"; + + if (always_root || page) + html_attr(cgit_rooturl()); + else { + char *currenturl = cgit_currenturl(); + html_attr(currenturl); + free(currenturl); + } + + if (page) { + htmlf("?p=%s", page); + delim = "&"; + } + if (search) { + html(delim); + html("q="); + html_attr(search); + delim = "&"; + } + if (sort) { + html(delim); + html("s="); + html_attr(sort); + delim = "&"; + } + if (ofs) { + html(delim); + htmlf("ofs=%d", ofs); + } +} + +static void site_link(const char *page, const char *name, const char *title, + const char *class, const char *search, const char *sort, int ofs, int always_root) +{ + html("<a"); + if (title) { + html(" title='"); + html_attr(title); + html("'"); + } + if (class) { + html(" class='"); + html_attr(class); + html("'"); + } + html(" href='"); + site_url(page, search, sort, ofs, always_root); + html("'>"); + html_txt(name); + html("</a>"); +} + +void cgit_index_link(const char *name, const char *title, const char *class, + const char *pattern, const char *sort, int ofs, int always_root) +{ + site_link(NULL, name, title, class, pattern, sort, ofs, always_root); +} + +static char *repolink(const char *title, const char *class, const char *page, + const char *head, const char *path) +{ + char *delim = "?"; + + html("<a"); + if (title) { + html(" title='"); + html_attr(title); + html("'"); + } + if (class) { + html(" class='"); + html_attr(class); + html("'"); + } + html(" href='"); + if (ctx.cfg.virtual_root) { + html_url_path(ctx.cfg.virtual_root); + if (page) { + html_url_path(page); + html("/"); + if (path) + html_url_path(path); + } + } else { + html_url_path(ctx.cfg.script_name); + html("?url="); + html_url_arg(ctx.repo->url); + if (ctx.repo->url[strlen(ctx.repo->url) - 1] != '/') + html("/"); + if (page) { + html_url_arg(page); + html("/"); + if (path) + html_url_arg(path); + } + delim = "&"; + } + if (head && ctx.repo->defbranch && strcmp(head, ctx.repo->defbranch)) { + html(delim); + html("h="); + html_url_arg(head); + delim = "&"; + } + return fmt("%s", delim); +} + +static void reporevlink(const char *page, const char *name, const char *title, + const char *class, const char *head, const char *rev, + const char *path) +{ + char *delim; + + delim = repolink(title, class, page, head, path); + if (rev && ctx.qry.head != NULL && strcmp(rev, ctx.qry.head)) { + html(delim); + html("id="); + html_url_arg(rev); + } + html("'>"); + html_txt(name); + html("</a>"); +} + +void cgit_summary_link(const char *name, const char *title, const char *class, + const char *head) +{ + reporevlink(NULL, name, title, class, head, NULL, NULL); +} + +void cgit_tag_link(const char *name, const char *title, const char *class, + const char *tag) +{ + reporevlink("tag", name, title, class, tag, NULL, NULL); +} + +void cgit_about_link(const char *name, const char *title, const char *class, + const char *head, const char *rev, const char *path) +{ + reporevlink("about", name, title, class, head, rev, path); +} + +void cgit_tree_link(const char *name, const char *title, const char *class, + const char *head, const char *rev, const char *path) +{ + reporevlink("tree", name, title, class, head, rev, path); +} + +void cgit_plain_link(const char *name, const char *title, const char *class, + const char *head, const char *rev, const char *path) +{ + reporevlink("plain", name, title, class, head, rev, path); +} + +void cgit_blame_link(const char *name, const char *title, const char *class, + const char *head, const char *rev, const char *path) +{ + reporevlink("blame", name, title, class, head, rev, path); +} + +void cgit_log_link(const char *name, const char *title, const char *class, + const char *head, const char *rev, const char *path, + int ofs, const char *grep, const char *pattern, int showmsg, + int follow) +{ + char *delim; + + delim = repolink(title, class, "log", head, path); + if (rev && ctx.qry.head && strcmp(rev, ctx.qry.head)) { + html(delim); + html("id="); + html_url_arg(rev); + delim = "&"; + } + if (grep && pattern) { + html(delim); + html("qt="); + html_url_arg(grep); + delim = "&"; + html(delim); + html("q="); + html_url_arg(pattern); + } + if (ofs > 0) { + html(delim); + html("ofs="); + htmlf("%d", ofs); + delim = "&"; + } + if (showmsg) { + html(delim); + html("showmsg=1"); + delim = "&"; + } + if (follow) { + html(delim); + html("follow=1"); + } + html("'>"); + html_txt(name); + html("</a>"); +} + +void cgit_commit_link(const char *name, const char *title, const char *class, + const char *head, const char *rev, const char *path) +{ + char *delim; + + delim = repolink(title, class, "commit", head, path); + if (rev && ctx.qry.head && strcmp(rev, ctx.qry.head)) { + html(delim); + html("id="); + html_url_arg(rev); + delim = "&"; + } + if (ctx.qry.difftype) { + html(delim); + htmlf("dt=%d", ctx.qry.difftype); + delim = "&"; + } + if (ctx.qry.context > 0 && ctx.qry.context != 3) { + html(delim); + html("context="); + htmlf("%d", ctx.qry.context); + delim = "&"; + } + if (ctx.qry.ignorews) { + html(delim); + html("ignorews=1"); + delim = "&"; + } + if (ctx.qry.follow) { + html(delim); + html("follow=1"); + } + html("'>"); + if (name[0] != '\0') { + if (strlen(name) > ctx.cfg.max_msg_len && ctx.cfg.max_msg_len >= 15) { + html_ntxt(name, ctx.cfg.max_msg_len - 3); + html("..."); + } else + html_txt(name); + } else + html_txt("(no commit message)"); + html("</a>"); +} + +void cgit_refs_link(const char *name, const char *title, const char *class, + const char *head, const char *rev, const char *path) +{ + reporevlink("refs", name, title, class, head, rev, path); +} + +void cgit_snapshot_link(const char *name, const char *title, const char *class, + const char *head, const char *rev, + const char *archivename) +{ + reporevlink("snapshot", name, title, class, head, rev, archivename); +} + +void cgit_diff_link(const char *name, const char *title, const char *class, + const char *head, const char *new_rev, const char *old_rev, + const char *path) +{ + char *delim; + + delim = repolink(title, class, "diff", head, path); + if (new_rev && ctx.qry.head != NULL && strcmp(new_rev, ctx.qry.head)) { + html(delim); + html("id="); + html_url_arg(new_rev); + delim = "&"; + } + if (old_rev) { + html(delim); + html("id2="); + html_url_arg(old_rev); + delim = "&"; + } + if (ctx.qry.difftype) { + html(delim); + htmlf("dt=%d", ctx.qry.difftype); + delim = "&"; + } + if (ctx.qry.context > 0 && ctx.qry.context != 3) { + html(delim); + html("context="); + htmlf("%d", ctx.qry.context); + delim = "&"; + } + if (ctx.qry.ignorews) { + html(delim); + html("ignorews=1"); + delim = "&"; + } + if (ctx.qry.follow) { + html(delim); + html("follow=1"); + } + html("'>"); + html_txt(name); + html("</a>"); +} + +void cgit_patch_link(const char *name, const char *title, const char *class, + const char *head, const char *rev, const char *path) +{ + reporevlink("patch", name, title, class, head, rev, path); +} + +void cgit_stats_link(const char *name, const char *title, const char *class, + const char *head, const char *path) +{ + reporevlink("stats", name, title, class, head, NULL, path); +} + +static void cgit_self_link(char *name, const char *title, const char *class) +{ + if (!strcmp(ctx.qry.page, "repolist")) + cgit_index_link(name, title, class, ctx.qry.search, ctx.qry.sort, + ctx.qry.ofs, 1); + else if (!strcmp(ctx.qry.page, "about")) + cgit_about_link(name, title, class, ctx.qry.head, + ctx.qry.has_oid ? ctx.qry.oid : NULL, + ctx.qry.path); + else if (!strcmp(ctx.qry.page, "summary")) + cgit_summary_link(name, title, class, ctx.qry.head); + else if (!strcmp(ctx.qry.page, "tag")) + cgit_tag_link(name, title, class, ctx.qry.has_oid ? + ctx.qry.oid : ctx.qry.head); + else if (!strcmp(ctx.qry.page, "tree")) + cgit_tree_link(name, title, class, ctx.qry.head, + ctx.qry.has_oid ? ctx.qry.oid : NULL, + ctx.qry.path); + else if (!strcmp(ctx.qry.page, "plain")) + cgit_plain_link(name, title, class, ctx.qry.head, + ctx.qry.has_oid ? ctx.qry.oid : NULL, + ctx.qry.path); + else if (!strcmp(ctx.qry.page, "blame")) + cgit_blame_link(name, title, class, ctx.qry.head, + ctx.qry.has_oid ? ctx.qry.oid : NULL, + ctx.qry.path); + else if (!strcmp(ctx.qry.page, "log")) + cgit_log_link(name, title, class, ctx.qry.head, + ctx.qry.has_oid ? ctx.qry.oid : NULL, + ctx.qry.path, ctx.qry.ofs, + ctx.qry.grep, ctx.qry.search, + ctx.qry.showmsg, ctx.qry.follow); + else if (!strcmp(ctx.qry.page, "commit")) + cgit_commit_link(name, title, class, ctx.qry.head, + ctx.qry.has_oid ? ctx.qry.oid : NULL, + ctx.qry.path); + else if (!strcmp(ctx.qry.page, "patch")) + cgit_patch_link(name, title, class, ctx.qry.head, + ctx.qry.has_oid ? ctx.qry.oid : NULL, + ctx.qry.path); + else if (!strcmp(ctx.qry.page, "refs")) + cgit_refs_link(name, title, class, ctx.qry.head, + ctx.qry.has_oid ? ctx.qry.oid : NULL, + ctx.qry.path); + else if (!strcmp(ctx.qry.page, "snapshot")) + cgit_snapshot_link(name, title, class, ctx.qry.head, + ctx.qry.has_oid ? ctx.qry.oid : NULL, + ctx.qry.path); + else if (!strcmp(ctx.qry.page, "diff")) + cgit_diff_link(name, title, class, ctx.qry.head, + ctx.qry.oid, ctx.qry.oid2, + ctx.qry.path); + else if (!strcmp(ctx.qry.page, "stats")) + cgit_stats_link(name, title, class, ctx.qry.head, + ctx.qry.path); + else { + /* Don't known how to make link for this page */ + repolink(title, class, ctx.qry.page, ctx.qry.head, ctx.qry.path); + html("><!-- cgit_self_link() doesn't know how to make link for page '"); + html_txt(ctx.qry.page); + html("' -->"); + html_txt(name); + html("</a>"); + } +} + +void cgit_object_link(struct object *obj) +{ + char *page, *shortrev, *fullrev, *name; + + fullrev = oid_to_hex(&obj->oid); + shortrev = xstrdup(fullrev); + shortrev[10] = '\0'; + if (obj->type == OBJ_COMMIT) { + cgit_commit_link(fmt("commit %s...", shortrev), NULL, NULL, + ctx.qry.head, fullrev, NULL); + return; + } else if (obj->type == OBJ_TREE) + page = "tree"; + else if (obj->type == OBJ_TAG) + page = "tag"; + else + page = "blob"; + name = fmt("%s %s...", type_name(obj->type), shortrev); + reporevlink(page, name, NULL, NULL, ctx.qry.head, fullrev, NULL); +} + +static struct string_list_item *lookup_path(struct string_list *list, + const char *path) +{ + struct string_list_item *item; + + while (path && path[0]) { + if ((item = string_list_lookup(list, path))) + return item; + if (!(path = strchr(path, '/'))) + break; + path++; + } + return NULL; +} + +void cgit_submodule_link(const char *class, char *path, const char *rev) +{ + struct string_list *list; + struct string_list_item *item; + char tail, *dir; + size_t len; + + len = 0; + tail = 0; + list = &ctx.repo->submodules; + item = lookup_path(list, path); + if (!item) { + len = strlen(path); + tail = path[len - 1]; + if (tail == '/') { + path[len - 1] = 0; + item = lookup_path(list, path); + } + } + if (item || ctx.repo->module_link) { + html("<a "); + if (class) + htmlf("class='%s' ", class); + html("href='"); + if (item) { + html_attrf(item->util, rev); + } else { + dir = strrchr(path, '/'); + if (dir) + dir++; + else + dir = path; + html_attrf(ctx.repo->module_link, dir, rev); + } + html("'>"); + html_txt(path); + html("</a>"); + } else { + html("<span"); + if (class) + htmlf(" class='%s'", class); + html(">"); + html_txt(path); + html("</span>"); + } + html_txtf(" @ %.7s", rev); + if (item && tail) + path[len - 1] = tail; +} + +const struct date_mode *cgit_date_mode(enum date_mode_type type) +{ + static struct date_mode mode; + mode.type = type; + mode.local = ctx.cfg.local_time; + return &mode; +} + +static void print_rel_date(time_t t, int tz, double value, + const char *class, const char *suffix) +{ + htmlf("<span class='%s' title='", class); + html_attr(show_date(t, tz, cgit_date_mode(DATE_DOTTIME))); + htmlf("'>%.0f %s</span>", value, suffix); +} + +void cgit_print_age(time_t t, int tz, time_t max_relative) +{ + time_t now, secs; + + if (!t) + return; + time(&now); + secs = now - t; + if (secs < 0) + secs = 0; + + if (secs > max_relative && max_relative >= 0) { + html("<span title='"); + html_attr(show_date(t, tz, cgit_date_mode(DATE_DOTTIME))); + html("'>"); + html_txt(show_date(t, tz, cgit_date_mode(DATE_SHORT))); + html("</span>"); + return; + } + + if (secs < TM_HOUR * 2) { + print_rel_date(t, tz, secs * 1.0 / TM_MIN, "age-mins", "min."); + return; + } + if (secs < TM_DAY * 2) { + print_rel_date(t, tz, secs * 1.0 / TM_HOUR, "age-hours", "hours"); + return; + } + if (secs < TM_WEEK * 2) { + print_rel_date(t, tz, secs * 1.0 / TM_DAY, "age-days", "days"); + return; + } + if (secs < TM_MONTH * 2) { + print_rel_date(t, tz, secs * 1.0 / TM_WEEK, "age-weeks", "weeks"); + return; + } + if (secs < TM_YEAR * 2) { + print_rel_date(t, tz, secs * 1.0 / TM_MONTH, "age-months", "months"); + return; + } + print_rel_date(t, tz, secs * 1.0 / TM_YEAR, "age-years", "years"); +} + +void cgit_print_http_headers(void) +{ + if (ctx.env.no_http && !strcmp(ctx.env.no_http, "1")) + return; + + if (ctx.page.status) + htmlf("Status: %d %s\n", ctx.page.status, ctx.page.statusmsg); + if (ctx.page.mimetype && ctx.page.charset) + htmlf("Content-Type: %s; charset=%s\n", ctx.page.mimetype, + ctx.page.charset); + else if (ctx.page.mimetype) + htmlf("Content-Type: %s\n", ctx.page.mimetype); + if (ctx.page.size) + htmlf("Content-Length: %zd\n", ctx.page.size); + if (ctx.page.filename) { + html("Content-Disposition: inline; filename=\""); + html_header_arg_in_quotes(ctx.page.filename); + html("\"\n"); + } + if (!ctx.env.authenticated) + html("Cache-Control: no-cache, no-store\n"); + htmlf("Last-Modified: %s\n", http_date(ctx.page.modified)); + htmlf("Expires: %s\n", http_date(ctx.page.expires)); + if (ctx.page.etag) + htmlf("ETag: \"%s\"\n", ctx.page.etag); + html("\n"); + if (ctx.env.request_method && !strcmp(ctx.env.request_method, "HEAD")) + exit(0); +} + +void cgit_redirect(const char *url, bool permanent) +{ + htmlf("Status: %d %s\n", permanent ? 301 : 302, permanent ? "Moved" : "Found"); + html("Location: "); + html_url_path(url); + html("\n\n"); +} + +static void print_rel_vcs_link(const char *url) +{ + html("<link rel='vcs-git' href='"); + html_attr(url); + html("' title='"); + html_attr(ctx.repo->name); + html(" Git repository'/>\n"); +} + +void cgit_print_docstart(void) +{ + char *host = cgit_hosturl(); + + if (ctx.cfg.embedded) { + if (ctx.cfg.header) + html_include(ctx.cfg.header); + return; + } + + html(cgit_doctype); + html("<html lang='en'>\n"); + html("<head>\n"); + html("<title>"); + html_txt(ctx.page.title); + html("</title>\n"); + htmlf("<meta name='generator' content='cgit %s'/>\n", cgit_version); + if (ctx.cfg.robots && *ctx.cfg.robots) + htmlf("<meta name='robots' content='%s'/>\n", ctx.cfg.robots); + html("<link rel='stylesheet' type='text/css' href='"); + html_attr(ctx.cfg.css); + html("'/>\n"); + if (ctx.cfg.favicon) { + html("<link rel='shortcut icon' href='"); + html_attr(ctx.cfg.favicon); + html("'/>\n"); + } + if (host && ctx.repo && ctx.qry.head) { + char *fileurl; + struct strbuf sb = STRBUF_INIT; + strbuf_addf(&sb, "h=%s", ctx.qry.head); + + html("<link rel='alternate' title='Atom feed' href='"); + html(cgit_httpscheme()); + html_attr(host); + fileurl = cgit_fileurl(ctx.repo->url, "atom", ctx.qry.vpath, + sb.buf); + html_attr(fileurl); + html("' type='application/atom+xml'/>\n"); + strbuf_release(&sb); + free(fileurl); + } + if (ctx.repo) + cgit_add_clone_urls(print_rel_vcs_link); + if (ctx.cfg.head_include) + html_include(ctx.cfg.head_include); + if (ctx.repo && ctx.repo->extra_head_content) + html(ctx.repo->extra_head_content); + html("</head>\n"); + html("<body>\n"); + if (ctx.cfg.header) + html_include(ctx.cfg.header); + free(host); +} + +void cgit_print_docend(void) +{ + html("</div> <!-- class=content -->\n"); + if (ctx.cfg.embedded) { + html("</div> <!-- id=cgit -->\n"); + if (ctx.cfg.footer) + html_include(ctx.cfg.footer); + return; + } + if (ctx.cfg.footer) + html_include(ctx.cfg.footer); + else { + htmlf("<div class='footer'>generated by <a href='https://git.causal.agency/cgit-pink/about/'>cgit-pink %s</a> " + "(<a href='https://git-scm.com/'>git %s</a>) at ", cgit_version, git_version_string); + html_txt(show_date(time(NULL), 0, cgit_date_mode(DATE_DOTTIME))); + html("</div>\n"); + } + html("</div> <!-- id=cgit -->\n"); + html("</body>\n</html>\n"); +} + +void cgit_print_error_page(int code, const char *msg, const char *fmt, ...) +{ + va_list ap; + ctx.page.expires = ctx.cfg.cache_dynamic_ttl; + ctx.page.status = code; + ctx.page.statusmsg = msg; + cgit_print_layout_start(); + va_start(ap, fmt); + cgit_vprint_error(fmt, ap); + va_end(ap); + cgit_print_layout_end(); +} + +void cgit_print_layout_start(void) +{ + cgit_print_http_headers(); + cgit_print_docstart(); + cgit_print_pageheader(); +} + +void cgit_print_layout_end(void) +{ + cgit_print_docend(); +} + +static void add_clone_urls(void (*fn)(const char *), char *txt, char *suffix) +{ + struct strbuf **url_list = strbuf_split_str(txt, ' ', 0); + int i; + + for (i = 0; url_list[i]; i++) { + strbuf_rtrim(url_list[i]); + if (url_list[i]->len == 0) + continue; + if (suffix && *suffix) + strbuf_addf(url_list[i], "/%s", suffix); + fn(url_list[i]->buf); + } + + strbuf_list_free(url_list); +} + +void cgit_add_clone_urls(void (*fn)(const char *)) +{ + if (ctx.repo->clone_url) + add_clone_urls(fn, expand_macros(ctx.repo->clone_url), NULL); + else if (ctx.cfg.clone_prefix) + add_clone_urls(fn, ctx.cfg.clone_prefix, ctx.repo->url); +} + +static int print_this_commit_option(void) +{ + struct object_id oid; + if (!ctx.qry.head || repo_get_oid(the_repository, ctx.qry.head, &oid)) + return 1; + html_option(oid_to_hex(&oid), "this commit", ctx.qry.head); + return 0; +} + +static int print_branch_option(const char *refname, const struct object_id *oid, + int flags, void *cb_data) +{ + char *name = (char *)refname; + html_option(name, name, ctx.qry.head); + return 0; +} + +void cgit_add_hidden_formfields(int incl_head, int incl_search, + const char *page) +{ + if (!ctx.cfg.virtual_root) { + struct strbuf url = STRBUF_INIT; + + strbuf_addf(&url, "%s/%s", ctx.qry.repo, page); + if (ctx.qry.vpath) + strbuf_addf(&url, "/%s", ctx.qry.vpath); + html_hidden("url", url.buf); + strbuf_release(&url); + } + + if (incl_head && ctx.qry.head && ctx.repo->defbranch && + strcmp(ctx.qry.head, ctx.repo->defbranch)) + html_hidden("h", ctx.qry.head); + + if (ctx.qry.oid) + html_hidden("id", ctx.qry.oid); + if (ctx.qry.oid2) + html_hidden("id2", ctx.qry.oid2); + if (ctx.qry.showmsg) + html_hidden("showmsg", "1"); + + if (incl_search) { + if (ctx.qry.grep) + html_hidden("qt", ctx.qry.grep); + if (ctx.qry.search) + html_hidden("q", ctx.qry.search); + } +} + +static const char *hc(const char *page) +{ + if (!ctx.qry.page) + return NULL; + + return strcmp(ctx.qry.page, page) ? NULL : "active"; +} + +static void cgit_print_path_crumbs(char *path) +{ + char *old_path = ctx.qry.path; + char *p = path, *q, *end = path + strlen(path); + int levels = 0; + + ctx.qry.path = NULL; + cgit_self_link("root", NULL, NULL); + ctx.qry.path = p = path; + while (p < end) { + if (!(q = strchr(p, '/')) || levels > 15) + q = end; + *q = '\0'; + html_txt("/"); + cgit_self_link(p, NULL, NULL); + if (q < end) + *q = '/'; + p = q + 1; + ++levels; + } + ctx.qry.path = old_path; +} + +static void print_header(void) +{ + char *logo = NULL, *logo_link = NULL; + + html("<table id='header'>\n"); + html("<tr>\n"); + + if (ctx.repo && ctx.repo->logo && *ctx.repo->logo) + logo = ctx.repo->logo; + else + logo = ctx.cfg.logo; + if (ctx.repo && ctx.repo->logo_link && *ctx.repo->logo_link) + logo_link = ctx.repo->logo_link; + else + logo_link = ctx.cfg.logo_link; + if (logo && *logo) { + html("<td class='logo' rowspan='2'><a href='"); + if (logo_link && *logo_link) + html_attr(logo_link); + else + html_attr(cgit_rooturl()); + html("'><img src='"); + html_attr(logo); + html("' alt='cgit logo'/></a></td>\n"); + } + + html("<td class='main'>"); + if (ctx.repo) { + cgit_summary_link(ctx.repo->name, NULL, NULL, NULL); + if (ctx.env.authenticated) { + html("</td><td class='form'>"); + html("<form method='get'>\n"); + cgit_add_hidden_formfields(0, 1, ctx.qry.page); + html("<select name='h' onchange='this.form.submit();'>\n"); + print_this_commit_option(); + html("<optgroup label='branches'>"); + for_each_branch_ref(print_branch_option, ctx.qry.head); + if (ctx.repo->enable_remote_branches) + for_each_remote_ref(print_branch_option, ctx.qry.head); + html("</optgroup>"); + html("</select> "); + html("<input type='submit' value='switch'/>"); + html("</form>"); + } + } else + html_txt(ctx.cfg.root_title); + html("</td></tr>\n"); + + html("<tr><td class='sub'>"); + if (ctx.repo) { + html_txt(ctx.repo->desc); + html("</td><td class='sub right'>"); + if (ctx.repo->owner_filter) { + cgit_open_filter(ctx.repo->owner_filter); + html_txt(ctx.repo->owner); + cgit_close_filter(ctx.repo->owner_filter); + } else { + html_txt(ctx.repo->owner); + } + } else { + if (ctx.cfg.root_desc) + html_txt(ctx.cfg.root_desc); + } + html("</td></tr></table>\n"); +} + +void cgit_print_pageheader(void) +{ + html("<div id='cgit'>"); + if (!ctx.env.authenticated || !ctx.cfg.noheader) + print_header(); + + html("<table class='tabs'><tr><td>\n"); + if (ctx.env.authenticated && ctx.repo) { + if (ctx.repo->readme.nr) { + cgit_about_link("about", NULL, hc("about"), ctx.qry.head, + ctx.qry.oid, ctx.qry.vpath); + html(" "); + } + cgit_summary_link("summary", NULL, hc("summary"), + ctx.qry.head); + html(" "); + cgit_refs_link("refs", NULL, hc("refs"), ctx.qry.head, + ctx.qry.oid, NULL); + html(" "); + cgit_log_link("log", NULL, hc("log"), ctx.qry.head, + NULL, ctx.qry.vpath, 0, NULL, NULL, + ctx.qry.showmsg, ctx.qry.follow); + html(" "); + if (ctx.qry.page && !strcmp(ctx.qry.page, "blame")) + cgit_blame_link("blame", NULL, hc("blame"), ctx.qry.head, + ctx.qry.oid, ctx.qry.vpath); + else + cgit_tree_link("tree", NULL, hc("tree"), ctx.qry.head, + ctx.qry.oid, ctx.qry.vpath); + html(" "); + cgit_commit_link("commit", NULL, hc("commit"), + ctx.qry.head, ctx.qry.oid, ctx.qry.vpath); + html(" "); + cgit_diff_link("diff", NULL, hc("diff"), ctx.qry.head, + ctx.qry.oid, ctx.qry.oid2, ctx.qry.vpath); + if (ctx.repo->max_stats) { + html(" "); + cgit_stats_link("stats", NULL, hc("stats"), + ctx.qry.head, ctx.qry.vpath); + } + if (ctx.repo->homepage) { + html(" <a href='"); + html_attr(ctx.repo->homepage); + html("'>homepage</a>"); + } + html("</td><td class='form'>"); + html("<form class='right' method='get' action='"); + if (ctx.cfg.virtual_root) { + char *fileurl = cgit_fileurl(ctx.qry.repo, "log", + ctx.qry.vpath, NULL); + html_url_path(fileurl); + free(fileurl); + } + html("'>\n"); + cgit_add_hidden_formfields(1, 0, "log"); + html("<select name='qt'>\n"); + html_option("grep", "log msg", ctx.qry.grep); + html_option("author", "author", ctx.qry.grep); + html_option("committer", "committer", ctx.qry.grep); + html_option("range", "range", ctx.qry.grep); + html("</select>\n"); + html("<input class='txt' type='search' size='10' name='q' value='"); + html_attr(ctx.qry.search); + html("'/>\n"); + html("<input type='submit' value='search'/>\n"); + html("</form>\n"); + } else if (ctx.env.authenticated) { + char *currenturl = cgit_currenturl(); + site_link(NULL, "index", NULL, hc("repolist"), NULL, NULL, 0, 1); + if (ctx.cfg.root_readme) + site_link("about", "about", NULL, hc("about"), + NULL, NULL, 0, 1); + html("</td><td class='form'>"); + html("<form method='get' action='"); + html_attr(currenturl); + html("'>\n"); + html("<input type='search' name='q' size='10' value='"); + html_attr(ctx.qry.search); + html("'/>\n"); + html("<input type='submit' value='search'/>\n"); + html("</form>"); + free(currenturl); + } + html("</td></tr></table>\n"); + if (ctx.env.authenticated && ctx.repo && ctx.qry.vpath) { + html("<div class='path'>"); + html("path: "); + cgit_print_path_crumbs(ctx.qry.vpath); + if (ctx.cfg.enable_follow_links && !strcmp(ctx.qry.page, "log")) { + html(" ("); + ctx.qry.follow = !ctx.qry.follow; + cgit_self_link(ctx.qry.follow ? "follow" : "unfollow", + NULL, NULL); + ctx.qry.follow = !ctx.qry.follow; + html(")"); + } + html("</div>"); + } + html("<div class='content'>"); +} + +void cgit_print_filemode(unsigned short mode) +{ + if (S_ISDIR(mode)) + html("d"); + else if (S_ISLNK(mode)) + html("l"); + else if (S_ISGITLINK(mode)) + html("m"); + else + html("-"); + html_fileperm(mode >> 6); + html_fileperm(mode >> 3); + html_fileperm(mode); +} + +void cgit_compose_snapshot_prefix(struct strbuf *filename, const char *base, + const char *ref) +{ + struct object_id oid; + + /* + * Prettify snapshot names by stripping leading "v" or "V" if the tag + * name starts with {v,V}[0-9] and the prettify mapping is injective, + * i.e. each stripped tag can be inverted without ambiguities. + */ + if (repo_get_oid(the_repository, fmt("refs/tags/%s", ref), &oid) == 0 && + (ref[0] == 'v' || ref[0] == 'V') && isdigit(ref[1]) && + ((repo_get_oid(the_repository, fmt("refs/tags/%s", ref + 1), &oid) == 0) + + (repo_get_oid(the_repository, fmt("refs/tags/v%s", ref + 1), &oid) == 0) + + (repo_get_oid(the_repository, fmt("refs/tags/V%s", ref + 1), &oid) == 0) == 1)) + ref++; + + strbuf_addf(filename, "%s-%s", base, ref); +} + +void cgit_print_snapshot_links(const struct cgit_repo *repo, const char *ref, + const char *separator) +{ + const struct cgit_snapshot_format *f; + struct strbuf filename = STRBUF_INIT; + const char *basename; + size_t prefixlen; + + basename = cgit_snapshot_prefix(repo); + if (starts_with(ref, basename)) + strbuf_addstr(&filename, ref); + else + cgit_compose_snapshot_prefix(&filename, basename, ref); + + prefixlen = filename.len; + for (f = cgit_snapshot_formats; f->suffix; f++) { + if (!(repo->snapshots & cgit_snapshot_format_bit(f))) + continue; + strbuf_setlen(&filename, prefixlen); + strbuf_addstr(&filename, f->suffix); + cgit_snapshot_link(filename.buf, NULL, NULL, NULL, NULL, + filename.buf); + if (cgit_snapshot_get_sig(ref, f)) { + strbuf_addstr(&filename, ".asc"); + html(" ("); + cgit_snapshot_link("sig", NULL, NULL, NULL, NULL, + filename.buf); + html(")"); + } else if (starts_with(f->suffix, ".tar") && cgit_snapshot_get_sig(ref, &cgit_snapshot_formats[0])) { + strbuf_setlen(&filename, strlen(filename.buf) - strlen(f->suffix)); + strbuf_addstr(&filename, ".tar.asc"); + html(" ("); + cgit_snapshot_link("sig", NULL, NULL, NULL, NULL, + filename.buf); + html(")"); + } + html(separator); + } + strbuf_release(&filename); +} + +void cgit_set_title_from_path(const char *path) +{ + struct strbuf sb = STRBUF_INIT; + const char *slash, *last_slash; + + if (!path) + return; + + last_slash = path + strlen(path); + for (slash = last_slash; slash > path; --slash) { + if (*slash != '/') continue; + strbuf_add(&sb, slash + 1, last_slash - slash - 1); + strbuf_addstr(&sb, " \xc2\xab "); + last_slash = slash; + } + strbuf_add(&sb, path, last_slash - path); + strbuf_addf(&sb, " - %s", ctx.page.title); + ctx.page.title = strbuf_detach(&sb, NULL); +} diff --git a/third_party/cgit/ui-shared.h b/third_party/cgit/ui-shared.h new file mode 100644 index 0000000000..6964873a63 --- /dev/null +++ b/third_party/cgit/ui-shared.h @@ -0,0 +1,87 @@ +#ifndef UI_SHARED_H +#define UI_SHARED_H + +extern const char *cgit_httpscheme(void); +extern char *cgit_hosturl(void); +extern const char *cgit_rooturl(void); +extern char *cgit_currenturl(void); +extern char *cgit_currentfullurl(void); +extern const char *cgit_loginurl(void); +extern char *cgit_repourl(const char *reponame); +extern char *cgit_fileurl(const char *reponame, const char *pagename, + const char *filename, const char *query); +extern char *cgit_pageurl(const char *reponame, const char *pagename, + const char *query); + +extern void cgit_add_clone_urls(void (*fn)(const char *)); + +extern void cgit_index_link(const char *name, const char *title, + const char *class, const char *pattern, const char *sort, int ofs, int always_root); +extern void cgit_summary_link(const char *name, const char *title, + const char *class, const char *head); +extern void cgit_tag_link(const char *name, const char *title, + const char *class, const char *tag); +extern void cgit_tree_link(const char *name, const char *title, + const char *class, const char *head, + const char *rev, const char *path); +extern void cgit_plain_link(const char *name, const char *title, + const char *class, const char *head, + const char *rev, const char *path); +extern void cgit_blame_link(const char *name, const char *title, + const char *class, const char *head, + const char *rev, const char *path); +extern void cgit_log_link(const char *name, const char *title, + const char *class, const char *head, const char *rev, + const char *path, int ofs, const char *grep, + const char *pattern, int showmsg, int follow); +extern void cgit_commit_link(const char *name, const char *title, + const char *class, const char *head, + const char *rev, const char *path); +extern void cgit_patch_link(const char *name, const char *title, + const char *class, const char *head, + const char *rev, const char *path); +extern void cgit_refs_link(const char *name, const char *title, + const char *class, const char *head, + const char *rev, const char *path); +extern void cgit_snapshot_link(const char *name, const char *title, + const char *class, const char *head, + const char *rev, const char *archivename); +extern void cgit_diff_link(const char *name, const char *title, + const char *class, const char *head, + const char *new_rev, const char *old_rev, + const char *path); +extern void cgit_stats_link(const char *name, const char *title, + const char *class, const char *head, + const char *path); +extern void cgit_object_link(struct object *obj); + +extern void cgit_submodule_link(const char *class, char *path, + const char *rev); + +extern void cgit_print_layout_start(void); +extern void cgit_print_layout_end(void); + +__attribute__((format (printf,1,2))) +extern void cgit_print_error(const char *fmt, ...); +__attribute__((format (printf,1,0))) +extern void cgit_vprint_error(const char *fmt, va_list ap); +extern const struct date_mode *cgit_date_mode(enum date_mode_type type); +extern void cgit_print_age(time_t t, int tz, time_t max_relative); +extern void cgit_print_http_headers(void); +extern void cgit_redirect(const char *url, bool permanent); +extern void cgit_print_docstart(void); +extern void cgit_print_docend(void); +__attribute__((format (printf,3,4))) +extern void cgit_print_error_page(int code, const char *msg, const char *fmt, ...); +extern void cgit_print_pageheader(void); +extern void cgit_print_filemode(unsigned short mode); +extern void cgit_compose_snapshot_prefix(struct strbuf *filename, + const char *base, const char *ref); +extern void cgit_print_snapshot_links(const struct cgit_repo *repo, + const char *ref, const char *separator); +extern const char *cgit_snapshot_prefix(const struct cgit_repo *repo); +extern void cgit_add_hidden_formfields(int incl_head, int incl_search, + const char *page); + +extern void cgit_set_title_from_path(const char *path); +#endif /* UI_SHARED_H */ diff --git a/third_party/cgit/ui-snapshot.c b/third_party/cgit/ui-snapshot.c new file mode 100644 index 0000000000..992853bcd7 --- /dev/null +++ b/third_party/cgit/ui-snapshot.c @@ -0,0 +1,319 @@ +/* ui-snapshot.c: generate snapshot of a commit + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "ui-snapshot.h" +#include "html.h" +#include "ui-shared.h" + +static int write_archive_type(const char *format, const char *hex, const char *prefix) +{ + struct strvec argv = STRVEC_INIT; + const char **nargv; + int result; + strvec_push(&argv, "snapshot"); + strvec_push(&argv, format); + if (prefix) { + struct strbuf buf = STRBUF_INIT; + strbuf_addstr(&buf, prefix); + strbuf_addch(&buf, '/'); + strvec_push(&argv, "--prefix"); + strvec_push(&argv, buf.buf); + strbuf_release(&buf); + } + strvec_push(&argv, hex); + /* + * Now we need to copy the pointers to arguments into a new + * structure because write_archive will rearrange its arguments + * which may result in duplicated/missing entries causing leaks + * or double-frees in strvec_clear. + */ + nargv = xmalloc(sizeof(char *) * (argv.nr + 1)); + /* strvec guarantees a trailing NULL entry. */ + memcpy(nargv, argv.v, sizeof(char *) * (argv.nr + 1)); + + if (fflush(stdout)) + return errno; + + result = write_archive(argv.nr, nargv, NULL, the_repository, NULL, 0); + strvec_clear(&argv); + free(nargv); + return result; +} + +static int write_tar_archive(const char *hex, const char *prefix) +{ + return write_archive_type("--format=tar", hex, prefix); +} + +static int write_zip_archive(const char *hex, const char *prefix) +{ + return write_archive_type("--format=zip", hex, prefix); +} + +static int write_compressed_tar_archive(const char *hex, + const char *prefix, + char *filter_argv[]) +{ + int rv; + struct cgit_exec_filter f; + cgit_exec_filter_init(&f, filter_argv[0], filter_argv); + + cgit_open_filter(&f.base); + rv = write_tar_archive(hex, prefix); + cgit_close_filter(&f.base); + return rv; +} + +static int write_tar_gzip_archive(const char *hex, const char *prefix) +{ + char *argv[] = { "gzip", "-n", NULL }; + return write_compressed_tar_archive(hex, prefix, argv); +} + +static int write_tar_bzip2_archive(const char *hex, const char *prefix) +{ + char *argv[] = { "bzip2", NULL }; + return write_compressed_tar_archive(hex, prefix, argv); +} + +static int write_tar_lzip_archive(const char *hex, const char *prefix) +{ + char *argv[] = { "lzip", NULL }; + return write_compressed_tar_archive(hex, prefix, argv); +} + +static int write_tar_xz_archive(const char *hex, const char *prefix) +{ + char *argv[] = { "xz", NULL }; + return write_compressed_tar_archive(hex, prefix, argv); +} + +static int write_tar_zstd_archive(const char *hex, const char *prefix) +{ + char *argv[] = { "zstd", "-T0", NULL }; + return write_compressed_tar_archive(hex, prefix, argv); +} + +const struct cgit_snapshot_format cgit_snapshot_formats[] = { + /* .tar must remain the 0 index */ + { ".tar", "application/x-tar", write_tar_archive }, + { ".tar.gz", "application/x-gzip", write_tar_gzip_archive }, + { ".tar.bz2", "application/x-bzip2", write_tar_bzip2_archive }, + { ".tar.lz", "application/x-lzip", write_tar_lzip_archive }, + { ".tar.xz", "application/x-xz", write_tar_xz_archive }, + { ".tar.zst", "application/x-zstd", write_tar_zstd_archive }, + { ".zip", "application/x-zip", write_zip_archive }, + { NULL } +}; + +static struct notes_tree snapshot_sig_notes[ARRAY_SIZE(cgit_snapshot_formats)]; + +const struct object_id *cgit_snapshot_get_sig(const char *ref, + const struct cgit_snapshot_format *f) +{ + struct notes_tree *tree; + struct object_id oid; + + if (repo_get_oid(the_repository, ref, &oid)) + return NULL; + + tree = &snapshot_sig_notes[f - &cgit_snapshot_formats[0]]; + if (!tree->initialized) { + struct strbuf notes_ref = STRBUF_INIT; + + strbuf_addf(¬es_ref, "refs/notes/signatures/%s", + f->suffix + 1); + + init_notes(tree, notes_ref.buf, combine_notes_ignore, 0); + strbuf_release(¬es_ref); + } + + return get_note(tree, &oid); +} + +static const struct cgit_snapshot_format *get_format(const char *filename) +{ + const struct cgit_snapshot_format *fmt; + + for (fmt = cgit_snapshot_formats; fmt->suffix; fmt++) { + if (ends_with(filename, fmt->suffix)) + return fmt; + } + return NULL; +} + +const unsigned cgit_snapshot_format_bit(const struct cgit_snapshot_format *f) +{ + return BIT(f - &cgit_snapshot_formats[0]); +} + +static int make_snapshot(const struct cgit_snapshot_format *format, + const char *hex, const char *prefix, + const char *filename) +{ + struct object_id oid; + + if (repo_get_oid(the_repository, hex, &oid)) { + cgit_print_error_page(404, "Not found", + "Bad object id: %s", hex); + return 1; + } + if (!lookup_commit_reference(the_repository, &oid)) { + cgit_print_error_page(400, "Bad request", + "Not a commit reference: %s", hex); + return 1; + } + ctx.page.etag = oid_to_hex(&oid); + ctx.page.mimetype = xstrdup(format->mimetype); + ctx.page.filename = xstrdup(filename); + cgit_print_http_headers(); + init_archivers(); + format->write_func(hex, prefix); + return 0; +} + +static int write_sig(const struct cgit_snapshot_format *format, + const char *hex, const char *archive, + const char *filename) +{ + const struct object_id *note = cgit_snapshot_get_sig(hex, format); + enum object_type type; + unsigned long size; + char *buf; + + if (!note) { + cgit_print_error_page(404, "Not found", + "No signature for %s", archive); + return 0; + } + + buf = repo_read_object_file(the_repository, note, &type, &size); + if (!buf) { + cgit_print_error_page(404, "Not found", "Not found"); + return 0; + } + + html("X-Content-Type-Options: nosniff\n"); + html("Content-Security-Policy: default-src 'none'\n"); + ctx.page.etag = oid_to_hex(note); + ctx.page.mimetype = xstrdup("application/pgp-signature"); + ctx.page.filename = xstrdup(filename); + cgit_print_http_headers(); + + html_raw(buf, size); + free(buf); + return 0; +} + +/* Try to guess the requested revision from the requested snapshot name. + * First the format extension is stripped, e.g. "cgit-0.7.2.tar.gz" become + * "cgit-0.7.2". If this is a valid commit object name we've got a winner. + * Otherwise, if the snapshot name has a prefix matching the result from + * repo_basename(), we strip the basename and any following '-' and '_' + * characters ("cgit-0.7.2" -> "0.7.2") and check the resulting name once + * more. If this still isn't a valid commit object name, we check if pre- + * pending a 'v' or a 'V' to the remaining snapshot name ("0.7.2" -> + * "v0.7.2") gives us something valid. + */ +static const char *get_ref_from_filename(const struct cgit_repo *repo, + const char *filename, + const struct cgit_snapshot_format *format) +{ + const char *reponame; + struct object_id oid; + struct strbuf snapshot = STRBUF_INIT; + int result = 1; + + strbuf_addstr(&snapshot, filename); + strbuf_setlen(&snapshot, snapshot.len - strlen(format->suffix)); + + if (repo_get_oid(the_repository, snapshot.buf, &oid) == 0) + goto out; + + reponame = cgit_snapshot_prefix(repo); + if (starts_with(snapshot.buf, reponame)) { + const char *new_start = snapshot.buf; + new_start += strlen(reponame); + while (new_start && (*new_start == '-' || *new_start == '_')) + new_start++; + strbuf_splice(&snapshot, 0, new_start - snapshot.buf, "", 0); + } + + if (repo_get_oid(the_repository, snapshot.buf, &oid) == 0) + goto out; + + strbuf_insert(&snapshot, 0, "v", 1); + if (repo_get_oid(the_repository, snapshot.buf, &oid) == 0) + goto out; + + strbuf_splice(&snapshot, 0, 1, "V", 1); + if (repo_get_oid(the_repository, snapshot.buf, &oid) == 0) + goto out; + + result = 0; + strbuf_release(&snapshot); + +out: + return result ? strbuf_detach(&snapshot, NULL) : NULL; +} + +void cgit_print_snapshot(const char *head, const char *hex, + const char *filename, int dwim) +{ + const struct cgit_snapshot_format* f; + const char *sig_filename = NULL; + char *adj_filename = NULL; + char *prefix = NULL; + + if (!filename) { + cgit_print_error_page(400, "Bad request", + "No snapshot name specified"); + return; + } + + if (ends_with(filename, ".asc")) { + sig_filename = filename; + + /* Strip ".asc" from filename for common format processing */ + adj_filename = xstrdup(filename); + adj_filename[strlen(adj_filename) - 4] = '\0'; + filename = adj_filename; + } + + f = get_format(filename); + if (!f || (!sig_filename && !(ctx.repo->snapshots & cgit_snapshot_format_bit(f)))) { + cgit_print_error_page(400, "Bad request", + "Unsupported snapshot format: %s", filename); + return; + } + + if (!hex && dwim) { + hex = get_ref_from_filename(ctx.repo, filename, f); + if (hex == NULL) { + cgit_print_error_page(404, "Not found", "Not found"); + return; + } + prefix = xstrdup(filename); + prefix[strlen(filename) - strlen(f->suffix)] = '\0'; + } + + if (!hex) + hex = head; + + if (!prefix) + prefix = xstrdup(cgit_snapshot_prefix(ctx.repo)); + + if (sig_filename) + write_sig(f, hex, filename, sig_filename); + else + make_snapshot(f, hex, prefix, filename); + + free(prefix); + free(adj_filename); +} diff --git a/third_party/cgit/ui-snapshot.h b/third_party/cgit/ui-snapshot.h new file mode 100644 index 0000000000..a8deec3697 --- /dev/null +++ b/third_party/cgit/ui-snapshot.h @@ -0,0 +1,7 @@ +#ifndef UI_SNAPSHOT_H +#define UI_SNAPSHOT_H + +extern void cgit_print_snapshot(const char *head, const char *hex, + const char *filename, int dwim); + +#endif /* UI_SNAPSHOT_H */ diff --git a/third_party/cgit/ui-ssdiff.c b/third_party/cgit/ui-ssdiff.c new file mode 100644 index 0000000000..af8bc9e065 --- /dev/null +++ b/third_party/cgit/ui-ssdiff.c @@ -0,0 +1,420 @@ +#include "cgit.h" +#include "ui-ssdiff.h" +#include "html.h" +#include "ui-shared.h" +#include "ui-diff.h" + +extern int use_ssdiff; + +static int current_old_line, current_new_line; +static int **L = NULL; + +struct deferred_lines { + int line_no; + char *line; + struct deferred_lines *next; +}; + +static struct deferred_lines *deferred_old, *deferred_old_last; +static struct deferred_lines *deferred_new, *deferred_new_last; + +static void create_or_reset_lcs_table(void) +{ + int i; + + if (L != NULL) { + memset(*L, 0, sizeof(int) * MAX_SSDIFF_SIZE); + return; + } + + // xcalloc will die if we ran out of memory; + // not very helpful for debugging + L = (int**)xcalloc(MAX_SSDIFF_M, sizeof(int *)); + *L = (int*)xcalloc(MAX_SSDIFF_SIZE, sizeof(int)); + + for (i = 1; i < MAX_SSDIFF_M; i++) { + L[i] = *L + i * MAX_SSDIFF_N; + } +} + +static char *longest_common_subsequence(char *A, char *B) +{ + int i, j, ri; + int m = strlen(A); + int n = strlen(B); + int tmp1, tmp2; + int lcs_length; + char *result; + + // We bail if the lines are too long + if (m >= MAX_SSDIFF_M || n >= MAX_SSDIFF_N) + return NULL; + + create_or_reset_lcs_table(); + + for (i = m; i >= 0; i--) { + for (j = n; j >= 0; j--) { + if (A[i] == '\0' || B[j] == '\0') { + L[i][j] = 0; + } else if (A[i] == B[j]) { + L[i][j] = 1 + L[i + 1][j + 1]; + } else { + tmp1 = L[i + 1][j]; + tmp2 = L[i][j + 1]; + L[i][j] = (tmp1 > tmp2 ? tmp1 : tmp2); + } + } + } + + lcs_length = L[0][0]; + result = xmalloc(lcs_length + 2); + memset(result, 0, sizeof(*result) * (lcs_length + 2)); + + ri = 0; + i = 0; + j = 0; + while (i < m && j < n) { + if (A[i] == B[j]) { + result[ri] = A[i]; + ri += 1; + i += 1; + j += 1; + } else if (L[i + 1][j] >= L[i][j + 1]) { + i += 1; + } else { + j += 1; + } + } + + return result; +} + +static int line_from_hunk(char *line, char type) +{ + char *buf1, *buf2; + int len, res; + + buf1 = strchr(line, type); + if (buf1 == NULL) + return 0; + buf1 += 1; + buf2 = strchr(buf1, ','); + if (buf2 == NULL) + return 0; + len = buf2 - buf1; + buf2 = xmalloc(len + 1); + strlcpy(buf2, buf1, len + 1); + res = atoi(buf2); + free(buf2); + return res; +} + +static char *replace_tabs(char *line) +{ + char *prev_buf = line; + char *cur_buf; + size_t linelen = strlen(line); + int n_tabs = 0; + int i; + char *result; + size_t result_len; + + if (linelen == 0) { + result = xmalloc(1); + result[0] = '\0'; + return result; + } + + for (i = 0; i < linelen; i++) { + if (line[i] == '\t') + n_tabs += 1; + } + result_len = linelen + n_tabs * 8; + result = xmalloc(result_len + 1); + result[0] = '\0'; + + for (;;) { + cur_buf = strchr(prev_buf, '\t'); + if (!cur_buf) { + linelen = strlen(result); + strlcpy(&result[linelen], prev_buf, result_len - linelen + 1); + break; + } else { + linelen = strlen(result); + strlcpy(&result[linelen], prev_buf, cur_buf - prev_buf + 1); + linelen = strlen(result); + memset(&result[linelen], ' ', 8 - (linelen % 8)); + result[linelen + 8 - (linelen % 8)] = '\0'; + } + prev_buf = cur_buf + 1; + } + return result; +} + +static int calc_deferred_lines(struct deferred_lines *start) +{ + struct deferred_lines *item = start; + int result = 0; + while (item) { + result += 1; + item = item->next; + } + return result; +} + +static void deferred_old_add(char *line, int line_no) +{ + struct deferred_lines *item = xmalloc(sizeof(struct deferred_lines)); + item->line = xstrdup(line); + item->line_no = line_no; + item->next = NULL; + if (deferred_old) { + deferred_old_last->next = item; + deferred_old_last = item; + } else { + deferred_old = deferred_old_last = item; + } +} + +static void deferred_new_add(char *line, int line_no) +{ + struct deferred_lines *item = xmalloc(sizeof(struct deferred_lines)); + item->line = xstrdup(line); + item->line_no = line_no; + item->next = NULL; + if (deferred_new) { + deferred_new_last->next = item; + deferred_new_last = item; + } else { + deferred_new = deferred_new_last = item; + } +} + +static void print_part_with_lcs(char *class, char *line, char *lcs) +{ + int line_len = strlen(line); + int i, j; + char c[2] = " "; + int same = 1; + + j = 0; + for (i = 0; i < line_len; i++) { + c[0] = line[i]; + if (same) { + if (line[i] == lcs[j]) + j += 1; + else { + same = 0; + htmlf("<span class='%s'>", class); + } + } else if (line[i] == lcs[j]) { + same = 1; + html("</span>"); + j += 1; + } + html_txt(c); + } + if (!same) + html("</span>"); +} + +static void print_ssdiff_line(char *class, + int old_line_no, + char *old_line, + int new_line_no, + char *new_line, int individual_chars) +{ + char *lcs = NULL; + + if (old_line) + old_line = replace_tabs(old_line + 1); + if (new_line) + new_line = replace_tabs(new_line + 1); + if (individual_chars && old_line && new_line) + lcs = longest_common_subsequence(old_line, new_line); + html("<tr>\n"); + if (old_line_no > 0) { + struct diff_filespec *old_file = cgit_get_current_old_file(); + char *lineno_str = fmt("n%d", old_line_no); + char *id_str = fmt("id=%s#%s", is_null_oid(&old_file->oid)?"HEAD":oid_to_hex(old_rev_oid), lineno_str); + char *fileurl = cgit_fileurl(ctx.repo->url, "tree", old_file->path, id_str); + html("<td class='lineno'><a href='"); + html(fileurl); + htmlf("'>%s</a>", lineno_str + 1); + html("</td>"); + htmlf("<td class='%s'>", class); + free(fileurl); + } else if (old_line) + htmlf("<td class='lineno'></td><td class='%s'>", class); + else + htmlf("<td class='lineno'></td><td class='%s_dark'>", class); + if (old_line) { + if (lcs) + print_part_with_lcs("del", old_line, lcs); + else + html_txt(old_line); + } + + html("</td>\n"); + if (new_line_no > 0) { + struct diff_filespec *new_file = cgit_get_current_new_file(); + char *lineno_str = fmt("n%d", new_line_no); + char *id_str = fmt("id=%s#%s", is_null_oid(&new_file->oid)?"HEAD":oid_to_hex(new_rev_oid), lineno_str); + char *fileurl = cgit_fileurl(ctx.repo->url, "tree", new_file->path, id_str); + html("<td class='lineno'><a href='"); + html(fileurl); + htmlf("'>%s</a>", lineno_str + 1); + html("</td>"); + htmlf("<td class='%s'>", class); + free(fileurl); + } else if (new_line) + htmlf("<td class='lineno'></td><td class='%s'>", class); + else + htmlf("<td class='lineno'></td><td class='%s_dark'>", class); + if (new_line) { + if (lcs) + print_part_with_lcs("add", new_line, lcs); + else + html_txt(new_line); + } + + html("</td></tr>"); + if (lcs) + free(lcs); + if (new_line) + free(new_line); + if (old_line) + free(old_line); +} + +static void print_deferred_old_lines(void) +{ + struct deferred_lines *iter_old, *tmp; + iter_old = deferred_old; + while (iter_old) { + print_ssdiff_line("del", iter_old->line_no, + iter_old->line, -1, NULL, 0); + tmp = iter_old->next; + free(iter_old); + iter_old = tmp; + } +} + +static void print_deferred_new_lines(void) +{ + struct deferred_lines *iter_new, *tmp; + iter_new = deferred_new; + while (iter_new) { + print_ssdiff_line("add", -1, NULL, + iter_new->line_no, iter_new->line, 0); + tmp = iter_new->next; + free(iter_new); + iter_new = tmp; + } +} + +static void print_deferred_changed_lines(void) +{ + struct deferred_lines *iter_old, *iter_new, *tmp; + int n_old_lines = calc_deferred_lines(deferred_old); + int n_new_lines = calc_deferred_lines(deferred_new); + int individual_chars = (n_old_lines == n_new_lines ? 1 : 0); + + iter_old = deferred_old; + iter_new = deferred_new; + while (iter_old || iter_new) { + if (iter_old && iter_new) + print_ssdiff_line("changed", iter_old->line_no, + iter_old->line, + iter_new->line_no, iter_new->line, + individual_chars); + else if (iter_old) + print_ssdiff_line("changed", iter_old->line_no, + iter_old->line, -1, NULL, 0); + else if (iter_new) + print_ssdiff_line("changed", -1, NULL, + iter_new->line_no, iter_new->line, 0); + if (iter_old) { + tmp = iter_old->next; + free(iter_old); + iter_old = tmp; + } + + if (iter_new) { + tmp = iter_new->next; + free(iter_new); + iter_new = tmp; + } + } +} + +void cgit_ssdiff_print_deferred_lines(void) +{ + if (!deferred_old && !deferred_new) + return; + if (deferred_old && !deferred_new) + print_deferred_old_lines(); + else if (!deferred_old && deferred_new) + print_deferred_new_lines(); + else + print_deferred_changed_lines(); + deferred_old = deferred_old_last = NULL; + deferred_new = deferred_new_last = NULL; +} + +/* + * print a single line returned from xdiff + */ +void cgit_ssdiff_line_cb(char *line, int len) +{ + char c = line[len - 1]; + line[len - 1] = '\0'; + if (line[0] == '@') { + current_old_line = line_from_hunk(line, '-'); + current_new_line = line_from_hunk(line, '+'); + } + + if (line[0] == ' ') { + if (deferred_old || deferred_new) + cgit_ssdiff_print_deferred_lines(); + print_ssdiff_line("ctx", current_old_line, line, + current_new_line, line, 0); + current_old_line += 1; + current_new_line += 1; + } else if (line[0] == '+') { + deferred_new_add(line, current_new_line); + current_new_line += 1; + } else if (line[0] == '-') { + deferred_old_add(line, current_old_line); + current_old_line += 1; + } else if (line[0] == '@') { + html("<tr><td colspan='4' class='hunk'>"); + html_txt(line); + html("</td></tr>"); + } else { + html("<tr><td colspan='4' class='ctx'>"); + html_txt(line); + html("</td></tr>"); + } + line[len - 1] = c; +} + +void cgit_ssdiff_header_begin(void) +{ + current_old_line = -1; + current_new_line = -1; + html("<tr><td class='space' colspan='4'><div></div></td></tr>"); + html("<tr><td class='head' colspan='4'>"); +} + +void cgit_ssdiff_header_end(void) +{ + html("</td></tr>"); +} + +void cgit_ssdiff_footer(void) +{ + if (deferred_old || deferred_new) + cgit_ssdiff_print_deferred_lines(); + html("<tr><td class='foot' colspan='4'></td></tr>"); +} diff --git a/third_party/cgit/ui-ssdiff.h b/third_party/cgit/ui-ssdiff.h new file mode 100644 index 0000000000..11f2714407 --- /dev/null +++ b/third_party/cgit/ui-ssdiff.h @@ -0,0 +1,25 @@ +#ifndef UI_SSDIFF_H +#define UI_SSDIFF_H + +/* + * ssdiff line limits + */ +#ifndef MAX_SSDIFF_M +#define MAX_SSDIFF_M 128 +#endif + +#ifndef MAX_SSDIFF_N +#define MAX_SSDIFF_N 128 +#endif +#define MAX_SSDIFF_SIZE ((MAX_SSDIFF_M) * (MAX_SSDIFF_N)) + +extern void cgit_ssdiff_print_deferred_lines(void); + +extern void cgit_ssdiff_line_cb(char *line, int len); + +extern void cgit_ssdiff_header_begin(void); +extern void cgit_ssdiff_header_end(void); + +extern void cgit_ssdiff_footer(void); + +#endif /* UI_SSDIFF_H */ diff --git a/third_party/cgit/ui-stats.c b/third_party/cgit/ui-stats.c new file mode 100644 index 0000000000..9aed4ac3bf --- /dev/null +++ b/third_party/cgit/ui-stats.c @@ -0,0 +1,425 @@ +#include "cgit.h" +#include "ui-stats.h" +#include "html.h" +#include "ui-shared.h" + +struct authorstat { + long total; + struct string_list list; +}; + +#define DAY_SECS (60 * 60 * 24) +#define WEEK_SECS (DAY_SECS * 7) + +static void trunc_week(struct tm *tm) +{ + time_t t = timegm(tm); + t -= ((tm->tm_wday + 6) % 7) * DAY_SECS; + gmtime_r(&t, tm); +} + +static void dec_week(struct tm *tm) +{ + time_t t = timegm(tm); + t -= WEEK_SECS; + gmtime_r(&t, tm); +} + +static void inc_week(struct tm *tm) +{ + time_t t = timegm(tm); + t += WEEK_SECS; + gmtime_r(&t, tm); +} + +static char *pretty_week(struct tm *tm) +{ + static char buf[10]; + + strftime(buf, sizeof(buf), "W%V %G", tm); + return buf; +} + +static void trunc_month(struct tm *tm) +{ + tm->tm_mday = 1; +} + +static void dec_month(struct tm *tm) +{ + tm->tm_mon--; + if (tm->tm_mon < 0) { + tm->tm_year--; + tm->tm_mon = 11; + } +} + +static void inc_month(struct tm *tm) +{ + tm->tm_mon++; + if (tm->tm_mon > 11) { + tm->tm_year++; + tm->tm_mon = 0; + } +} + +static char *pretty_month(struct tm *tm) +{ + static const char *months[] = { + "Jan", "Feb", "Mar", "Apr", "May", "Jun", + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" + }; + return fmt("%s %d", months[tm->tm_mon], tm->tm_year + 1900); +} + +static void trunc_quarter(struct tm *tm) +{ + trunc_month(tm); + while (tm->tm_mon % 3 != 0) + dec_month(tm); +} + +static void dec_quarter(struct tm *tm) +{ + dec_month(tm); + dec_month(tm); + dec_month(tm); +} + +static void inc_quarter(struct tm *tm) +{ + inc_month(tm); + inc_month(tm); + inc_month(tm); +} + +static char *pretty_quarter(struct tm *tm) +{ + return fmt("Q%d %d", tm->tm_mon / 3 + 1, tm->tm_year + 1900); +} + +static void trunc_year(struct tm *tm) +{ + trunc_month(tm); + tm->tm_mon = 0; +} + +static void dec_year(struct tm *tm) +{ + tm->tm_year--; +} + +static void inc_year(struct tm *tm) +{ + tm->tm_year++; +} + +static char *pretty_year(struct tm *tm) +{ + return fmt("%d", tm->tm_year + 1900); +} + +static const struct cgit_period periods[] = { + {'w', "week", 12, 4, trunc_week, dec_week, inc_week, pretty_week}, + {'m', "month", 12, 4, trunc_month, dec_month, inc_month, pretty_month}, + {'q', "quarter", 12, 4, trunc_quarter, dec_quarter, inc_quarter, pretty_quarter}, + {'y', "year", 12, 4, trunc_year, dec_year, inc_year, pretty_year}, +}; + +/* Given a period code or name, return a period index (1, 2, 3 or 4) + * and update the period pointer to the correcsponding struct. + * If no matching code is found, return 0. + */ +int cgit_find_stats_period(const char *expr, const struct cgit_period **period) +{ + int i; + char code = '\0'; + + if (!expr) + return 0; + + if (strlen(expr) == 1) + code = expr[0]; + + for (i = 0; i < sizeof(periods) / sizeof(periods[0]); i++) + if (periods[i].code == code || !strcmp(periods[i].name, expr)) { + if (period) + *period = &periods[i]; + return i + 1; + } + return 0; +} + +const char *cgit_find_stats_periodname(int idx) +{ + if (idx > 0 && idx < 4) + return periods[idx - 1].name; + else + return ""; +} + +static void add_commit(struct string_list *authors, struct commit *commit, + const struct cgit_period *period) +{ + struct commitinfo *info; + struct string_list_item *author, *item; + struct authorstat *authorstat; + struct string_list *items; + char *tmp; + struct tm date; + time_t t; + uintptr_t *counter; + + info = cgit_parse_commit(commit); + tmp = xstrdup(info->author); + author = string_list_insert(authors, tmp); + if (!author->util) + author->util = xcalloc(1, sizeof(struct authorstat)); + else + free(tmp); + authorstat = author->util; + items = &authorstat->list; + t = info->committer_date; + gmtime_r(&t, &date); + period->trunc(&date); + tmp = xstrdup(period->pretty(&date)); + item = string_list_insert(items, tmp); + counter = (uintptr_t *)&item->util; + if (*counter) + free(tmp); + (*counter)++; + + authorstat->total++; + cgit_free_commitinfo(info); +} + +static int cmp_total_commits(const void *a1, const void *a2) +{ + const struct string_list_item *i1 = a1; + const struct string_list_item *i2 = a2; + const struct authorstat *auth1 = i1->util; + const struct authorstat *auth2 = i2->util; + + return auth2->total - auth1->total; +} + +/* Walk the commit DAG and collect number of commits per author per + * timeperiod into a nested string_list collection. + */ +static struct string_list collect_stats(const struct cgit_period *period) +{ + struct string_list authors; + struct rev_info rev; + struct commit *commit; + const char *argv[] = {NULL, ctx.qry.head, NULL, NULL, NULL, NULL}; + int argc = 3; + time_t now; + long i; + struct tm tm; + char tmp[11]; + + time(&now); + gmtime_r(&now, &tm); + period->trunc(&tm); + for (i = 1; i < period->count; i++) + period->dec(&tm); + strftime(tmp, sizeof(tmp), "%Y-%m-%d", &tm); + argv[2] = xstrdup(fmt("--since=%s", tmp)); + if (ctx.qry.path) { + argv[3] = "--"; + argv[4] = ctx.qry.path; + argc += 2; + } + repo_init_revisions(the_repository, &rev, NULL); + rev.abbrev = DEFAULT_ABBREV; + rev.commit_format = CMIT_FMT_DEFAULT; + rev.max_parents = 1; + rev.verbose_header = 1; + rev.show_root_diff = 0; + setup_revisions(argc, argv, &rev, NULL); + prepare_revision_walk(&rev); + memset(&authors, 0, sizeof(authors)); + while ((commit = get_revision(&rev)) != NULL) { + add_commit(&authors, commit, period); + release_commit_memory(the_repository->parsed_objects, commit); + commit->parents = NULL; + } + return authors; +} + +static void print_combined_authorrow(struct string_list *authors, int from, + int to, const char *name, + const char *leftclass, + const char *centerclass, + const char *rightclass, + const struct cgit_period *period) +{ + struct string_list_item *author; + struct authorstat *authorstat; + struct string_list *items; + struct string_list_item *date; + time_t now; + long i, j, total, subtotal; + struct tm tm; + char *tmp; + + time(&now); + gmtime_r(&now, &tm); + period->trunc(&tm); + for (i = 1; i < period->count; i++) + period->dec(&tm); + + total = 0; + htmlf("<tr><td class='%s'>%s</td>", leftclass, + fmt(name, to - from + 1)); + for (j = 0; j < period->count; j++) { + tmp = period->pretty(&tm); + period->inc(&tm); + subtotal = 0; + for (i = from; i <= to; i++) { + author = &authors->items[i]; + authorstat = author->util; + items = &authorstat->list; + date = string_list_lookup(items, tmp); + if (date) + subtotal += (uintptr_t)date->util; + } + htmlf("<td class='%s'>%ld</td>", centerclass, subtotal); + total += subtotal; + } + htmlf("<td class='%s'>%ld</td></tr>", rightclass, total); +} + +static void print_authors(struct string_list *authors, int top, + const struct cgit_period *period) +{ + struct string_list_item *author; + struct authorstat *authorstat; + struct string_list *items; + struct string_list_item *date; + time_t now; + long i, j, total; + struct tm tm; + char *tmp; + + time(&now); + gmtime_r(&now, &tm); + period->trunc(&tm); + for (i = 1; i < period->count; i++) + period->dec(&tm); + + html("<table class='stats'><tr><th>Author</th>"); + for (j = 0; j < period->count; j++) { + tmp = period->pretty(&tm); + htmlf("<th>%s</th>", tmp); + period->inc(&tm); + } + html("<th>Total</th></tr>\n"); + + if (top <= 0 || top > authors->nr) + top = authors->nr; + + for (i = 0; i < top; i++) { + author = &authors->items[i]; + html("<tr><td class='left'>"); + html_txt(author->string); + html("</td>"); + authorstat = author->util; + items = &authorstat->list; + total = 0; + for (j = 0; j < period->count; j++) + period->dec(&tm); + for (j = 0; j < period->count; j++) { + tmp = period->pretty(&tm); + period->inc(&tm); + date = string_list_lookup(items, tmp); + if (!date) + html("<td>0</td>"); + else { + htmlf("<td>%lu</td>", (uintptr_t)date->util); + total += (uintptr_t)date->util; + } + } + htmlf("<td class='sum'>%ld</td></tr>", total); + } + + if (top < authors->nr) + print_combined_authorrow(authors, top, authors->nr - 1, + "Others (%ld)", "left", "", "sum", period); + + print_combined_authorrow(authors, 0, authors->nr - 1, "Total", + "total", "sum", "sum", period); + html("</table>"); +} + +/* Create a sorted string_list with one entry per author. The util-field + * for each author is another string_list which is used to calculate the + * number of commits per time-interval. + */ +void cgit_show_stats(void) +{ + struct string_list authors; + const struct cgit_period *period; + int top, i; + const char *code = "w"; + + if (ctx.qry.period) + code = ctx.qry.period; + + i = cgit_find_stats_period(code, &period); + if (!i) { + cgit_print_error_page(404, "Not found", + "Unknown statistics type: %c", code[0]); + return; + } + if (i > ctx.repo->max_stats) { + cgit_print_error_page(400, "Bad request", + "Statistics type disabled: %s", period->name); + return; + } + authors = collect_stats(period); + qsort(authors.items, authors.nr, sizeof(struct string_list_item), + cmp_total_commits); + + top = ctx.qry.ofs; + if (!top) + top = 10; + + cgit_print_layout_start(); + html("<div class='cgit-panel'>"); + html("<b>stat options</b>"); + html("<form method='get'>"); + cgit_add_hidden_formfields(1, 0, "stats"); + html("<table><tr><td colspan='2'/></tr>"); + if (ctx.repo->max_stats > 1) { + html("<tr><td class='label'>Period:</td>"); + html("<td class='ctrl'><select name='period' onchange='this.form.submit();'>"); + for (i = 0; i < ctx.repo->max_stats; i++) + html_option(fmt("%c", periods[i].code), + periods[i].name, fmt("%c", period->code)); + html("</select></td></tr>"); + } + html("<tr><td class='label'>Authors:</td>"); + html("<td class='ctrl'><select name='ofs' onchange='this.form.submit();'>"); + html_intoption(10, "10", top); + html_intoption(25, "25", top); + html_intoption(50, "50", top); + html_intoption(100, "100", top); + html_intoption(-1, "all", top); + html("</select></td></tr>"); + html("<tr><td/><td class='ctrl'>"); + html("<noscript><input type='submit' value='Reload'/></noscript>"); + html("</td></tr></table>"); + html("</form>"); + html("</div>"); + htmlf("<h2>Commits per author per %s", period->name); + if (ctx.qry.path) { + html(" (path '"); + html_txt(ctx.qry.path); + html("')"); + } + html("</h2>"); + print_authors(&authors, top, period); + cgit_print_layout_end(); +} + diff --git a/third_party/cgit/ui-stats.h b/third_party/cgit/ui-stats.h new file mode 100644 index 0000000000..0e61b03da3 --- /dev/null +++ b/third_party/cgit/ui-stats.h @@ -0,0 +1,28 @@ +#ifndef UI_STATS_H +#define UI_STATS_H + +#include "cgit.h" + +struct cgit_period { + const char code; + const char *name; + int max_periods; + int count; + + /* Convert a tm value to the first day in the period */ + void (*trunc)(struct tm *tm); + + /* Update tm value to start of next/previous period */ + void (*dec)(struct tm *tm); + void (*inc)(struct tm *tm); + + /* Pretty-print a tm value */ + char *(*pretty)(struct tm *tm); +}; + +extern int cgit_find_stats_period(const char *expr, const struct cgit_period **period); +extern const char *cgit_find_stats_periodname(int idx); + +extern void cgit_show_stats(void); + +#endif /* UI_STATS_H */ diff --git a/third_party/cgit/ui-summary.c b/third_party/cgit/ui-summary.c new file mode 100644 index 0000000000..ec7b76fabf --- /dev/null +++ b/third_party/cgit/ui-summary.c @@ -0,0 +1,163 @@ +/* ui-summary.c: functions for generating repo summary page + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "ui-summary.h" +#include "html.h" +#include "ui-blob.h" +#include "ui-log.h" +#include "ui-plain.h" +#include "ui-refs.h" +#include "ui-shared.h" + +static int urls; + +static void print_url(const char *url) +{ + int columns = 3; + + if (ctx.repo->enable_log_filecount) + columns++; + if (ctx.repo->enable_log_linecount) + columns++; + + if (urls++ == 0) { + htmlf("<tr class='nohover'><td colspan='%d'> </td></tr>", columns); + htmlf("<tr class='nohover'><th class='left' colspan='%d'>Clone</th></tr>\n", columns); + } + + htmlf("<tr><td colspan='%d'><a rel='vcs-git' href='", columns); + html_url_path(url); + html("' title='"); + html_attr(ctx.repo->name); + html(" Git repository'>"); + html_txt(url); + html("</a></td></tr>\n"); +} + +void cgit_print_summary(void) +{ + int columns = 3; + + if (ctx.repo->enable_log_filecount) + columns++; + if (ctx.repo->enable_log_linecount) + columns++; + + cgit_print_layout_start(); + html("<table summary='repository info' class='list nowrap'>"); + cgit_print_branches(ctx.cfg.summary_branches); + htmlf("<tr class='nohover'><td colspan='%d'> </td></tr>", columns); + cgit_print_tags(ctx.cfg.summary_tags); + if (ctx.cfg.summary_log > 0) { + htmlf("<tr class='nohover'><td colspan='%d'> </td></tr>", columns); + cgit_print_log(ctx.qry.head, 0, ctx.cfg.summary_log, NULL, + NULL, NULL, 0, 0, 0); + } + urls = 0; + cgit_add_clone_urls(print_url); + html("</table>"); + cgit_print_layout_end(); +} + +/* The caller must free the return value. */ +static char* append_readme_path(const char *filename, const char *ref, const char *path) +{ + char *file, *base_dir, *full_path, *resolved_base = NULL, *resolved_full = NULL; + /* If a subpath is specified for the about page, make it relative + * to the directory containing the configured readme. */ + + file = xstrdup(filename); + base_dir = dirname(file); + if (!strcmp(base_dir, ".") || !strcmp(base_dir, "..")) { + if (!ref) { + free(file); + return NULL; + } + full_path = xstrdup(path); + } else + full_path = fmtalloc("%s/%s", base_dir, path); + + if (!ref) { + resolved_base = realpath(base_dir, NULL); + resolved_full = realpath(full_path, NULL); + if (!resolved_base || !resolved_full || !starts_with(resolved_full, resolved_base)) { + free(full_path); + full_path = NULL; + } + } + + free(file); + free(resolved_base); + free(resolved_full); + + return full_path; +} + +void cgit_print_repo_readme(const char *path) +{ + char *filename, *ref, *mimetype; + int free_filename = 0; + + mimetype = get_mimetype_for_filename(path); + if (mimetype && (!strncmp(mimetype, "image/", 6) || !strncmp(mimetype, "video/", 6))) { + ctx.page.mimetype = mimetype; + ctx.page.charset = NULL; + cgit_print_plain(); + free(mimetype); + return; + } + free(mimetype); + + if (path) + ctx.page.title = fmtalloc("%s - %s", path, ctx.page.title); + + cgit_print_layout_start(); + if (ctx.repo->readme.nr == 0) + goto done; + + filename = ctx.repo->readme.items[0].string; + ref = ctx.repo->readme.items[0].util; + + if (path) { + free_filename = 1; + filename = append_readme_path(filename, ref, path); + if (!filename) + goto done; + } + + /* Determine which file to serve by checking whether the given filename is + * already a valid file and otherwise appending the expected file name of + * the readme. + * + * If neither yield a valid file, the user gets a blank page. Could probably + * do with an error message in between there, but whatever. + */ + if (path && ref && !cgit_ref_path_exists(filename, ref, 1)) { + filename = fmtalloc("%s/%s", path, ctx.repo->readme.items[0].string); + free_filename = 1; + } + + /* Print the calculated readme, either from the git repo or from the + * filesystem, while applying the about-filter. + */ + html("<div id='summary'>"); + cgit_open_filter(ctx.repo->about_filter, filename); + if (ref) + cgit_print_file(filename, ref, 1); + else + html_include(filename); + cgit_close_filter(ctx.repo->about_filter); + + html("</div>"); + if (free_filename) + free(filename); + +done: + cgit_print_layout_end(); +} diff --git a/third_party/cgit/ui-summary.h b/third_party/cgit/ui-summary.h new file mode 100644 index 0000000000..cba696af53 --- /dev/null +++ b/third_party/cgit/ui-summary.h @@ -0,0 +1,7 @@ +#ifndef UI_SUMMARY_H +#define UI_SUMMARY_H + +extern void cgit_print_summary(void); +extern void cgit_print_repo_readme(const char *path); + +#endif /* UI_SUMMARY_H */ diff --git a/third_party/cgit/ui-tag.c b/third_party/cgit/ui-tag.c new file mode 100644 index 0000000000..be1122b905 --- /dev/null +++ b/third_party/cgit/ui-tag.c @@ -0,0 +1,120 @@ +/* ui-tag.c: display a tag + * + * Copyright (C) 2006-2014 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "ui-tag.h" +#include "html.h" +#include "ui-shared.h" + +static void print_tag_content(char *buf) +{ + char *p; + + if (!buf) + return; + + html("<div class='commit-subject'>"); + p = strchr(buf, '\n'); + if (p) + *p = '\0'; + html_txt(buf); + html("</div>"); + if (p) { + html("<pre class='commit-msg'>"); + html_txt(++p); + html("</pre>"); + } +} + +static void print_download_links(char *revname) +{ + html("<tr><th>download</th><td class='oid'>"); + cgit_print_snapshot_links(ctx.repo, revname, "<br/>"); + html("</td></tr>"); +} + +void cgit_print_tag(char *revname) +{ + struct strbuf fullref = STRBUF_INIT; + struct object_id oid; + struct object *obj; + + if (!revname) + revname = ctx.qry.head; + + strbuf_addf(&fullref, "refs/tags/%s", revname); + if (repo_get_oid(the_repository, fullref.buf, &oid)) { + cgit_print_error_page(404, "Not found", + "Bad tag reference: %s", revname); + goto cleanup; + } + obj = parse_object(the_repository, &oid); + if (!obj) { + cgit_print_error_page(500, "Internal server error", + "Bad object id: %s", oid_to_hex(&oid)); + goto cleanup; + } + if (obj->type == OBJ_TAG) { + struct tag *tag; + struct taginfo *info; + + tag = lookup_tag(the_repository, &oid); + if (!tag || parse_tag(tag) || !(info = cgit_parse_tag(tag))) { + cgit_print_error_page(500, "Internal server error", + "Bad tag object: %s", revname); + goto cleanup; + } + cgit_print_layout_start(); + html("<table class='commit-info'>\n"); + html("<tr><td>tag name</td><td>"); + html_txt(revname); + htmlf(" (%s)</td></tr>\n", oid_to_hex(&oid)); + if (info->tagger_date > 0) { + html("<tr><td>tag date</td><td>"); + html_txt(show_date(info->tagger_date, info->tagger_tz, + cgit_date_mode(DATE_DOTTIME))); + html("</td></tr>\n"); + } + if (info->tagger) { + html("<tr><td>tagged by</td><td>"); + cgit_open_filter(ctx.repo->email_filter, info->tagger_email, "tag"); + html_txt(info->tagger); + if (info->tagger_email && !ctx.cfg.noplainemail) { + html(" "); + html_txt(info->tagger_email); + } + cgit_close_filter(ctx.repo->email_filter); + html("</td></tr>\n"); + } + html("<tr><td>tagged object</td><td class='oid'>"); + cgit_object_link(tag->tagged); + html("</td></tr>\n"); + if (ctx.repo->snapshots) + print_download_links(revname); + html("</table>\n"); + print_tag_content(info->msg); + cgit_print_layout_end(); + cgit_free_taginfo(info); + } else { + cgit_print_layout_start(); + html("<table class='commit-info'>\n"); + html("<tr><td>tag name</td><td>"); + html_txt(revname); + html("</td></tr>\n"); + html("<tr><td>tagged object</td><td class='oid'>"); + cgit_object_link(obj); + html("</td></tr>\n"); + if (ctx.repo->snapshots) + print_download_links(revname); + html("</table>\n"); + cgit_print_layout_end(); + } + +cleanup: + strbuf_release(&fullref); +} diff --git a/third_party/cgit/ui-tag.h b/third_party/cgit/ui-tag.h new file mode 100644 index 0000000000..d295cdcdbd --- /dev/null +++ b/third_party/cgit/ui-tag.h @@ -0,0 +1,6 @@ +#ifndef UI_TAG_H +#define UI_TAG_H + +extern void cgit_print_tag(char *revname); + +#endif /* UI_TAG_H */ diff --git a/third_party/cgit/ui-tree.c b/third_party/cgit/ui-tree.c new file mode 100644 index 0000000000..436b333809 --- /dev/null +++ b/third_party/cgit/ui-tree.c @@ -0,0 +1,411 @@ +/* ui-tree.c: functions for tree output + * + * Copyright (C) 2006-2017 cgit Development Team <cgit@lists.zx2c4.com> + * + * Licensed under GNU General Public License v2 + * (see COPYING for full license text) + */ + +#include "cgit.h" +#include "ui-tree.h" +#include "html.h" +#include "ui-shared.h" + +struct walk_tree_context { + char *curr_rev; + char *match_path; + int state; +}; + +static void print_text_buffer(const char *name, char *buf, unsigned long size) +{ + unsigned long lineno, idx; + const char *numberfmt = "<a id='n%1$d' href='#n%1$d'>%1$d</a>\n"; + + html("<table summary='blob content' class='blob'>\n"); + + if (ctx.cfg.enable_tree_linenumbers) { + html("<tr><td class='linenumbers'><pre>"); + idx = 0; + lineno = 0; + + if (size) { + htmlf(numberfmt, ++lineno); + while (idx < size - 1) { // skip absolute last newline + if (buf[idx] == '\n') + htmlf(numberfmt, ++lineno); + idx++; + } + } + html("</pre></td>\n"); + } + else { + html("<tr>\n"); + } + + if (ctx.repo->source_filter) { + char *filter_arg = xstrdup(name); + html("<td class='lines'><pre><code>"); + cgit_open_filter(ctx.repo->source_filter, filter_arg); + html_raw(buf, size); + cgit_close_filter(ctx.repo->source_filter); + free(filter_arg); + html("</code></pre></td></tr></table>\n"); + return; + } + + html("<td class='lines'><pre><code>"); + html_txt(buf); + html("</code></pre></td></tr></table>\n"); +} + +#define ROWLEN 32 + +static void print_binary_buffer(char *buf, unsigned long size) +{ + unsigned long ofs, idx; + static char ascii[ROWLEN + 1]; + + html("<table summary='blob content' class='bin-blob'>\n"); + html("<tr><th>ofs</th><th>hex dump</th><th>ascii</th></tr>"); + for (ofs = 0; ofs < size; ofs += ROWLEN, buf += ROWLEN) { + htmlf("<tr><td class='right'>%04lx</td><td class='hex'>", ofs); + for (idx = 0; idx < ROWLEN && ofs + idx < size; idx++) + htmlf("%*s%02x", + idx == 16 ? 4 : 1, "", + buf[idx] & 0xff); + html(" </td><td class='hex'>"); + for (idx = 0; idx < ROWLEN && ofs + idx < size; idx++) + ascii[idx] = isgraph(buf[idx]) ? buf[idx] : '.'; + ascii[idx] = '\0'; + html_txt(ascii); + html("</td></tr>\n"); + } + html("</table>\n"); +} + +static void print_object(const struct object_id *oid, const char *path, const char *basename, const char *rev) +{ + enum object_type type; + char *buf; + unsigned long size; + int is_binary; + + type = oid_object_info(the_repository, oid, &size); + if (type == OBJ_BAD) { + cgit_print_error_page(404, "Not found", + "Bad object name: %s", oid_to_hex(oid)); + return; + } + + buf = repo_read_object_file(the_repository, oid, &type, &size); + if (!buf) { + cgit_print_error_page(500, "Internal server error", + "Error reading object %s", oid_to_hex(oid)); + return; + } + is_binary = buffer_is_binary(buf, size); + + cgit_set_title_from_path(path); + + cgit_print_layout_start(); + htmlf("blob: %s (", oid_to_hex(oid)); + cgit_plain_link("plain", NULL, NULL, ctx.qry.head, + rev, path); + if (ctx.repo->enable_blame && !is_binary) { + html(") ("); + cgit_blame_link("blame", NULL, NULL, ctx.qry.head, + rev, path); + } + html(")\n"); + + if (ctx.cfg.max_blob_size && size / 1024 > ctx.cfg.max_blob_size) { + htmlf("<div class='error'>blob size (%ldKB) exceeds display size limit (%dKB).</div>", + size / 1024, ctx.cfg.max_blob_size); + return; + } + + if (is_binary) + print_binary_buffer(buf, size); + else + print_text_buffer(basename, buf, size); + + free(buf); +} + +struct single_tree_ctx { + struct strbuf *path; + struct object_id oid; + char *name; + size_t count; +}; + +static int single_tree_cb(const struct object_id *oid, struct strbuf *base, + const char *pathname, unsigned mode, void *cbdata) +{ + struct single_tree_ctx *ctx = cbdata; + + if (++ctx->count > 1) + return -1; + + if (!S_ISDIR(mode)) { + ctx->count = 2; + return -1; + } + + ctx->name = xstrdup(pathname); + oidcpy(&ctx->oid, oid); + strbuf_addf(ctx->path, "/%s", pathname); + return 0; +} + +static void write_tree_link(const struct object_id *oid, char *name, + char *rev, struct strbuf *fullpath) +{ + size_t initial_length = fullpath->len; + struct tree *tree; + struct single_tree_ctx tree_ctx = { + .path = fullpath, + .count = 1, + }; + struct pathspec paths = { + .nr = 0 + }; + + oidcpy(&tree_ctx.oid, oid); + + while (tree_ctx.count == 1) { + cgit_tree_link(name, NULL, "ls-dir", ctx.qry.head, rev, + fullpath->buf); + + tree = lookup_tree(the_repository, &tree_ctx.oid); + if (!tree) + return; + + free(tree_ctx.name); + tree_ctx.name = NULL; + tree_ctx.count = 0; + + read_tree(the_repository, tree, &paths, single_tree_cb, &tree_ctx); + + if (tree_ctx.count != 1) + break; + + html(" / "); + name = tree_ctx.name; + } + + strbuf_setlen(fullpath, initial_length); +} + +static int ls_item(const struct object_id *oid, struct strbuf *base, + const char *pathname, unsigned mode, void *cbdata) +{ + struct walk_tree_context *walk_tree_ctx = cbdata; + char *name; + struct strbuf fullpath = STRBUF_INIT; + struct strbuf linkpath = STRBUF_INIT; + struct strbuf class = STRBUF_INIT; + enum object_type type; + unsigned long size = 0; + char *buf; + + name = xstrdup(pathname); + strbuf_addf(&fullpath, "%s%s%s", ctx.qry.path ? ctx.qry.path : "", + ctx.qry.path ? "/" : "", name); + + if (!S_ISGITLINK(mode)) { + type = oid_object_info(the_repository, oid, &size); + if (type == OBJ_BAD) { + htmlf("<tr><td colspan='3'>Bad object: %s %s</td></tr>", + name, + oid_to_hex(oid)); + goto cleanup; + } + } + + html("<tr><td class='ls-mode'>"); + cgit_print_filemode(mode); + html("</td><td>"); + if (S_ISGITLINK(mode)) { + cgit_submodule_link("ls-mod", fullpath.buf, oid_to_hex(oid)); + } else if (S_ISDIR(mode)) { + write_tree_link(oid, name, walk_tree_ctx->curr_rev, + &fullpath); + } else { + char *ext = strrchr(name, '.'); + strbuf_addstr(&class, "ls-blob"); + if (ext) + strbuf_addf(&class, " %s", ext + 1); + cgit_tree_link(name, NULL, class.buf, ctx.qry.head, + walk_tree_ctx->curr_rev, fullpath.buf); + } + if (S_ISLNK(mode)) { + html(" -> "); + buf = repo_read_object_file(the_repository, oid, &type, &size); + if (!buf) { + htmlf("Error reading object: %s", oid_to_hex(oid)); + goto cleanup; + } + strbuf_addbuf(&linkpath, &fullpath); + strbuf_addf(&linkpath, "/../%s", buf); + strbuf_normalize_path(&linkpath); + cgit_tree_link(buf, NULL, class.buf, ctx.qry.head, + walk_tree_ctx->curr_rev, linkpath.buf); + free(buf); + strbuf_release(&linkpath); + } + htmlf("</td><td class='ls-size'>%li</td>", size); + + html("<td>"); + cgit_log_link("log", NULL, "button", ctx.qry.head, + walk_tree_ctx->curr_rev, fullpath.buf, 0, NULL, NULL, + ctx.qry.showmsg, 0); + if (ctx.repo->max_stats) { + html(" "); + cgit_stats_link("stats", NULL, "button", ctx.qry.head, + fullpath.buf); + } + if (!S_ISGITLINK(mode)) { + html(" "); + cgit_plain_link("plain", NULL, "button", ctx.qry.head, + walk_tree_ctx->curr_rev, fullpath.buf); + } + if (!S_ISDIR(mode) && ctx.repo->enable_blame) { + html(" "); + cgit_blame_link("blame", NULL, "button", ctx.qry.head, + walk_tree_ctx->curr_rev, fullpath.buf); + } + html("</td></tr>\n"); + +cleanup: + free(name); + strbuf_release(&fullpath); + strbuf_release(&class); + return 0; +} + +static void ls_head(void) +{ + cgit_print_layout_start(); + html("<table summary='tree listing' class='list'>\n"); + html("<tr class='nohover'>"); + html("<th class='left'>Mode</th>"); + html("<th class='left'>Name</th>"); + html("<th class='right'>Size</th>"); + html("<th/>"); + html("</tr>\n"); +} + +static void ls_tail(void) +{ + html("</table>\n"); + cgit_print_layout_end(); +} + +static void ls_tree(const struct object_id *oid, const char *path, struct walk_tree_context *walk_tree_ctx) +{ + struct tree *tree; + struct pathspec paths = { + .nr = 0 + }; + + tree = parse_tree_indirect(oid); + if (!tree) { + cgit_print_error_page(404, "Not found", + "Not a tree object: %s", oid_to_hex(oid)); + return; + } + + ls_head(); + read_tree(the_repository, tree, &paths, ls_item, walk_tree_ctx); + ls_tail(); +} + + +static int walk_tree(const struct object_id *oid, struct strbuf *base, + const char *pathname, unsigned mode, void *cbdata) +{ + struct walk_tree_context *walk_tree_ctx = cbdata; + + if (walk_tree_ctx->state == 0) { + struct strbuf buffer = STRBUF_INIT; + + strbuf_addbuf(&buffer, base); + strbuf_addstr(&buffer, pathname); + if (strcmp(walk_tree_ctx->match_path, buffer.buf)) + return READ_TREE_RECURSIVE; + + if (S_ISDIR(mode)) { + walk_tree_ctx->state = 1; + cgit_set_title_from_path(buffer.buf); + strbuf_release(&buffer); + ls_head(); + return READ_TREE_RECURSIVE; + } else { + walk_tree_ctx->state = 2; + print_object(oid, buffer.buf, pathname, walk_tree_ctx->curr_rev); + strbuf_release(&buffer); + return 0; + } + } + ls_item(oid, base, pathname, mode, walk_tree_ctx); + return 0; +} + +/* + * Show a tree or a blob + * rev: the commit pointing at the root tree object + * path: path to tree or blob + */ +void cgit_print_tree(const char *rev, char *path) +{ + struct object_id oid; + struct commit *commit; + struct pathspec_item path_items = { + .match = path, + .len = path ? strlen(path) : 0 + }; + struct pathspec paths = { + .nr = path ? 1 : 0, + .items = &path_items + }; + struct walk_tree_context walk_tree_ctx = { + .match_path = path, + .state = 0 + }; + + if (!rev) + rev = ctx.qry.head; + + if (repo_get_oid(the_repository, rev, &oid)) { + cgit_print_error_page(404, "Not found", + "Invalid revision name: %s", rev); + return; + } + commit = lookup_commit_reference(the_repository, &oid); + if (!commit || repo_parse_commit(the_repository, commit)) { + cgit_print_error_page(404, "Not found", + "Invalid commit reference: %s", rev); + return; + } + + walk_tree_ctx.curr_rev = xstrdup(rev); + + if (path == NULL) { + ls_tree(get_commit_tree_oid(commit), NULL, &walk_tree_ctx); + goto cleanup; + } + + read_tree(the_repository, repo_get_commit_tree(the_repository, commit), + &paths, walk_tree, &walk_tree_ctx); + if (walk_tree_ctx.state == 1) + ls_tail(); + else if (walk_tree_ctx.state == 2) + cgit_print_layout_end(); + else + cgit_print_error_page(404, "Not found", "Path not found"); + +cleanup: + free(walk_tree_ctx.curr_rev); +} diff --git a/third_party/cgit/ui-tree.h b/third_party/cgit/ui-tree.h new file mode 100644 index 0000000000..bbd34e3566 --- /dev/null +++ b/third_party/cgit/ui-tree.h @@ -0,0 +1,6 @@ +#ifndef UI_TREE_H +#define UI_TREE_H + +extern void cgit_print_tree(const char *rev, char *path); + +#endif /* UI_TREE_H */ diff --git a/third_party/clj2nix/OWNERS b/third_party/clj2nix/OWNERS new file mode 100644 index 0000000000..b381c4e660 --- /dev/null +++ b/third_party/clj2nix/OWNERS @@ -0,0 +1 @@ +aspen diff --git a/third_party/clj2nix/default.nix b/third_party/clj2nix/default.nix new file mode 100644 index 0000000000..f582debf29 --- /dev/null +++ b/third_party/clj2nix/default.nix @@ -0,0 +1,9 @@ +{ pkgs, ... }: + +pkgs.callPackage "${(pkgs.fetchFromGitHub { + owner = "hlolli"; + repo = "clj2nix"; + rev = "3d0a38c954c8e0926f57de1d80d357df05fc2f94"; + sha256 = "0y77b988qdgsrp4w72v1f5rrh33awbps2qdgp2wr2nmmi44541w5"; +})}/clj2nix.nix" +{ } diff --git a/third_party/ddclient/default.nix b/third_party/ddclient/default.nix new file mode 100644 index 0000000000..28b036ea66 --- /dev/null +++ b/third_party/ddclient/default.nix @@ -0,0 +1,12 @@ +# Users of this package & module should replace it with something like +# inadyn, after https://github.com/NixOS/nixpkgs/issues/242330 is +# landed. +# +# TODO(aspen): replace ddclient with inadyn or something else. +{ pkgs, ... }: + +(pkgs.callPackage ./pkg.nix { }).overrideAttrs (old: { + passthru = old.passthru // { + module = ./module.nix; + }; +}) diff --git a/third_party/ddclient/module.nix b/third_party/ddclient/module.nix new file mode 100644 index 0000000000..c8d68f9be9 --- /dev/null +++ b/third_party/ddclient/module.nix @@ -0,0 +1,230 @@ +# SPDX-License-Identifier: MIT +# SPDX-FileCopyrightText: Copyright (c) 2003-2023 The Nixpkgs/NixOS contributors +{ config, pkgs, lib, ... }: + +let + cfg = config.services.deprecated-ddclient; + boolToStr = bool: if bool then "yes" else "no"; + dataDir = "/var/lib/ddclient"; + StateDirectory = builtins.baseNameOf dataDir; + RuntimeDirectory = StateDirectory; + + configFile' = pkgs.writeText "ddclient.conf" '' + # This file can be used as a template for configFile or is automatically generated by Nix options. + cache=${dataDir}/ddclient.cache + foreground=YES + use=${cfg.use} + login=${cfg.username} + password=${if cfg.protocol == "nsupdate" then "/run/${RuntimeDirectory}/ddclient.key" else "@password_placeholder@"} + protocol=${cfg.protocol} + ${lib.optionalString (cfg.script != "") "script=${cfg.script}"} + ${lib.optionalString (cfg.server != "") "server=${cfg.server}"} + ${lib.optionalString (cfg.zone != "") "zone=${cfg.zone}"} + ssl=${boolToStr cfg.ssl} + wildcard=YES + quiet=${boolToStr cfg.quiet} + verbose=${boolToStr cfg.verbose} + ${cfg.extraConfig} + ${lib.concatStringsSep "," cfg.domains} + ''; + configFile = if (cfg.configFile != null) then cfg.configFile else configFile'; + + preStart = '' + install --mode=600 --owner=$USER ${configFile} /run/${RuntimeDirectory}/ddclient.conf + ${lib.optionalString (cfg.configFile == null) (if (cfg.protocol == "nsupdate") then '' + install --mode=600 --owner=$USER ${cfg.passwordFile} /run/${RuntimeDirectory}/ddclient.key + '' else if (cfg.passwordFile != null) then '' + "${pkgs.replace-secret}/bin/replace-secret" "@password_placeholder@" "${cfg.passwordFile}" "/run/${RuntimeDirectory}/ddclient.conf" + '' else '' + sed -i '/^password=@password_placeholder@$/d' /run/${RuntimeDirectory}/ddclient.conf + '')} + ''; + +in + +with lib; + +{ + ###### interface + + options = { + + services.deprecated-ddclient = with lib.types; { + + enable = mkOption { + default = false; + type = bool; + description = lib.mdDoc '' + Whether to synchronise your machine's IP address with a dynamic DNS provider (e.g. dyndns.org). + ''; + }; + + package = mkOption { + type = package; + default = pkgs.ddclient; + defaultText = lib.literalExpression "pkgs.ddclient"; + description = lib.mdDoc '' + The ddclient executable package run by the service. + ''; + }; + + domains = mkOption { + default = [ "" ]; + type = listOf str; + description = lib.mdDoc '' + Domain name(s) to synchronize. + ''; + }; + + username = mkOption { + # For `nsupdate` username contains the path to the nsupdate executable + default = lib.optionalString (cfg.protocol == "nsupdate") "${pkgs.bind.dnsutils}/bin/nsupdate"; + defaultText = ""; + type = str; + description = lib.mdDoc '' + User name. + ''; + }; + + passwordFile = mkOption { + default = null; + type = nullOr str; + description = lib.mdDoc '' + A file containing the password or a TSIG key in named format when using the nsupdate protocol. + ''; + }; + + interval = mkOption { + default = "10min"; + type = str; + description = lib.mdDoc '' + The interval at which to run the check and update. + See {command}`man 7 systemd.time` for the format. + ''; + }; + + configFile = mkOption { + default = null; + type = nullOr path; + description = lib.mdDoc '' + Path to configuration file. + When set this overrides the generated configuration from module options. + ''; + example = "/root/nixos/secrets/ddclient.conf"; + }; + + protocol = mkOption { + default = "dyndns2"; + type = str; + description = lib.mdDoc '' + Protocol to use with dynamic DNS provider (see https://sourceforge.net/p/ddclient/wiki/protocols). + ''; + }; + + server = mkOption { + default = ""; + type = str; + description = lib.mdDoc '' + Server address. + ''; + }; + + ssl = mkOption { + default = true; + type = bool; + description = lib.mdDoc '' + Whether to use SSL/TLS to connect to dynamic DNS provider. + ''; + }; + + quiet = mkOption { + default = false; + type = bool; + description = lib.mdDoc '' + Print no messages for unnecessary updates. + ''; + }; + + script = mkOption { + default = ""; + type = str; + description = lib.mdDoc '' + script as required by some providers. + ''; + }; + + use = mkOption { + default = "web, web=checkip.dyndns.com/, web-skip='Current IP Address: '"; + type = str; + description = lib.mdDoc '' + Method to determine the IP address to send to the dynamic DNS provider. + ''; + }; + + verbose = mkOption { + default = false; + type = bool; + description = lib.mdDoc '' + Print verbose information. + ''; + }; + + zone = mkOption { + default = ""; + type = str; + description = lib.mdDoc '' + zone as required by some providers. + ''; + }; + + extraConfig = mkOption { + default = ""; + type = lines; + description = lib.mdDoc '' + Extra configuration. Contents will be added verbatim to the configuration file. + ::: {.note} + `daemon` should not be added here because it does not work great with the systemd-timer approach the service uses. + ::: + ''; + }; + }; + }; + + + ###### implementation + + config = mkMerge [ + (mkIf cfg.enable { + systemd.services.ddclient = { + description = "Dynamic DNS Client"; + wantedBy = [ "multi-user.target" ]; + after = [ "network.target" ]; + restartTriggers = optional (cfg.configFile != null) cfg.configFile; + path = lib.optional (lib.hasPrefix "if," cfg.use) pkgs.iproute2; + + serviceConfig = { + DynamicUser = true; + RuntimeDirectoryMode = "0700"; + inherit RuntimeDirectory; + inherit StateDirectory; + Type = "oneshot"; + ExecStartPre = "!${pkgs.writeShellScript "ddclient-prestart" preStart}"; + ExecStart = "${lib.getBin cfg.package}/bin/ddclient -file /run/${RuntimeDirectory}/ddclient.conf"; + }; + }; + + systemd.timers.ddclient = { + description = "Run ddclient"; + wantedBy = [ "timers.target" ]; + timerConfig = { + OnBootSec = cfg.interval; + OnUnitInactiveSec = cfg.interval; + }; + }; + }) + { + ids.uids.ddclient = 30; + ids.gids.ddclient = 30; + } + ]; +} diff --git a/third_party/ddclient/pkg.nix b/third_party/ddclient/pkg.nix new file mode 100644 index 0000000000..586f3891ac --- /dev/null +++ b/third_party/ddclient/pkg.nix @@ -0,0 +1,45 @@ +# SPDX-License-Identifier: MIT +# SPDX-FileCopyrightText: Copyright (c) 2003-2023 The Nixpkgs/NixOS contributors +{ lib, fetchFromGitHub, perlPackages, autoreconfHook, iproute2, perl }: + +perlPackages.buildPerlPackage rec { + pname = "ddclient"; + version = "3.10.0"; + + outputs = [ "out" ]; + + src = fetchFromGitHub { + owner = "ddclient"; + repo = "ddclient"; + rev = "v${version}"; + sha256 = "sha256-wWUkjXwVNZRJR1rXPn3IkDRi9is9vsRuNC/zq8RpB1E="; + }; + + postPatch = '' + touch Makefile.PL + ''; + + nativeBuildInputs = [ autoreconfHook ]; + + buildInputs = with perlPackages; [ IOSocketINET6 IOSocketSSL JSONPP ]; + + installPhase = '' + runHook preInstall + # patch sheebang ddclient script which only exists after buildPhase + preConfigure + install -Dm755 ddclient $out/bin/ddclient + install -Dm644 -t $out/share/doc/ddclient COP* README.* ChangeLog.md + runHook postInstall + ''; + + # TODO: run upstream tests + doCheck = false; + + meta = with lib; { + description = "Client for updating dynamic DNS service entries"; + homepage = "https://ddclient.net/"; + license = licenses.gpl2Plus; + platforms = platforms.linux; + maintainers = with maintainers; [ SuperSandro2000 ]; + }; +} diff --git a/third_party/default.nix b/third_party/default.nix new file mode 100644 index 0000000000..874aecd3e7 --- /dev/null +++ b/third_party/default.nix @@ -0,0 +1,56 @@ +# This file defines the root of all external dependency imports (i.e. +# third-party code) in the TVL package tree. +# +# There are two categories of third-party programs: +# +# 1) Programs in nixpkgs, the NixOS package set. For these, you might +# want to look at //third_party/nixpkgs (for the package set +# imports) and //third_party/overlays (for modifications in these +# imported package sets). +# +# 2) Third-party software packaged in this repository. This is all +# other folders below //third_party, other than the ones mentioned +# above. + +{ pkgs, depot, localSystem, ... }: + +{ + # Expose a partially applied NixOS, expecting an attribute set with + # a `configuration` key. Exposing it like this makes it possible to + # modify some of the base configuration used by NixOS. + # + # This partially reimplements the code in + # <nixpkgs/nixos/default.nix> as we need to modify its internals to + # be able to pass `specialArgs`. We depend on this because `depot` + # needs to be partially evaluated in NixOS configuration before + # module imports are resolved. + nixos = + { configuration + , specialArgs ? { } + , system ? localSystem + , ... + }: + let + eval = import (pkgs.path + "/nixos/lib/eval-config.nix") { + inherit specialArgs system; + modules = [ + configuration + (import (depot.path.origSrc + "/ops/modules/default-imports.nix")) + ]; + }; + + # This is for `nixos-rebuild build-vm'. + vmConfig = (import (pkgs.path + "/nixos/lib/eval-config.nix") { + inherit specialArgs system; + modules = [ + configuration + (pkgs.path + "/nixos/modules/virtualisation/qemu-vm.nix") + ]; + }).config; + in + { + inherit (eval) pkgs config options; + system = eval.config.system.build.toplevel; + vm = vmConfig.system.build.vm; + }; +} diff --git a/third_party/elmPackages_0_18/default.nix b/third_party/elmPackages_0_18/default.nix new file mode 100644 index 0000000000..0481d0940a --- /dev/null +++ b/third_party/elmPackages_0_18/default.nix @@ -0,0 +1,21 @@ +# Backports Elm packages for Elm 0.18 from an older channel of +# nixpkgs. +# +# Elm 0.19 changed the language & package ecosystem completely, +# essentially requiring a partial rewrite of all Elm apps. However, +# //fun/gemma uses Elm 0.18 and I don't have time to rewrite it. +# +# Since the ABIs of current glibc and the pinned version have diverged +# too much, we need to build //fun/gemma completely based on a historical +# nixpkgs version. + +{ pkgs, ... }: + +(import + (pkgs.fetchFromGitHub { + owner = "NixOS"; + repo = "nixpkgs"; + rev = "14f9ee66e63077539252f8b4550049381a082518"; + sha256 = "1wn7nmb1cqfk2j91l3rwc6yhimfkzxprb8wknw5wi57yhq9m6lv1"; + }) +{ }) diff --git a/third_party/emacs/rcirc/default.nix b/third_party/emacs/rcirc/default.nix new file mode 100644 index 0000000000..f34cbed789 --- /dev/null +++ b/third_party/emacs/rcirc/default.nix @@ -0,0 +1,7 @@ +{ depot, ... }: + +depot.tools.emacs-pkgs.buildEmacsPackage rec { + pname = "rcirc"; + version = "1"; + src = ./rcirc.el; +} diff --git a/third_party/emacs/rcirc/rcirc.el b/third_party/emacs/rcirc/rcirc.el new file mode 100644 index 0000000000..b59cb4e9af --- /dev/null +++ b/third_party/emacs/rcirc/rcirc.el @@ -0,0 +1,3133 @@ +;;; rcirc.el --- default, simple IRC client -*- lexical-binding: t; -*- + +;; Copyright (C) 2005-2019 Free Software Foundation, Inc. + +;; Author: Ryan Yeske <rcyeske@gmail.com> +;; Maintainers: Ryan Yeske <rcyeske@gmail.com>, +;; Leo Liu <sdl.web@gmail.com> +;; Keywords: comm + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Internet Relay Chat (IRC) is a form of instant communication over +;; the Internet. It is mainly designed for group (many-to-many) +;; communication in discussion forums called channels, but also allows +;; one-to-one communication. + +;; Rcirc has simple defaults and clear and consistent behavior. +;; Message arrival timestamps, activity notification on the mode line, +;; message filling, nick completion, and keepalive pings are all +;; enabled by default, but can easily be adjusted or turned off. Each +;; discussion takes place in its own buffer and there is a single +;; server buffer per connection. + +;; Open a new irc connection with: +;; M-x irc RET + +;;; Todo: + +;;; Code: + +(require 'cl-lib) +(require 'ring) +(require 'time-date) +(require 'subr-x) + +(defgroup rcirc nil + "Simple IRC client." + :version "22.1" + :prefix "rcirc-" + :link '(custom-manual "(rcirc)") + :group 'applications) + +(defcustom rcirc-server-alist + '(("irc.freenode.net" :channels ("#rcirc") + ;; Don't use the TLS port by default, in case gnutls is not available. + ;; :port 7000 :encryption tls + )) + "An alist of IRC connections to establish when running `rcirc'. +Each element looks like (SERVER-NAME PARAMETERS). + +SERVER-NAME is a string describing the server to connect +to. + +The optional PARAMETERS come in pairs PARAMETER VALUE. + +The following parameters are recognized: + +`:nick' + +VALUE must be a string. If absent, `rcirc-default-nick' is used +for this connection. + +`:port' + +VALUE must be a number or string. If absent, +`rcirc-default-port' is used. + +`:user-name' + +VALUE must be a string. If absent, `rcirc-default-user-name' is +used. + +`:password' + +VALUE must be a string. If absent, no PASS command will be sent +to the server. + +`:full-name' + +VALUE must be a string. If absent, `rcirc-default-full-name' is +used. + +`:channels' + +VALUE must be a list of strings describing which channels to join +when connecting to this server. If absent, no channels will be +connected to automatically. + +`:encryption' + +VALUE must be `plain' (the default) for unencrypted connections, or `tls' +for connections using SSL/TLS. + +`:server-alias' + +VALUE must be a string that will be used instead of the server name for +display purposes. If absent, the real server name will be displayed instead." + :type '(alist :key-type string + :value-type (plist :options + ((:nick string) + (:port integer) + (:user-name string) + (:password string) + (:full-name string) + (:channels (repeat string)) + (:encryption (choice (const tls) + (const plain))) + (:server-alias string)))) + :group 'rcirc) + +(defcustom rcirc-default-port 6667 + "The default port to connect to." + :type 'integer + :group 'rcirc) + +(defcustom rcirc-default-nick (user-login-name) + "Your nick." + :type 'string + :group 'rcirc) + +(defcustom rcirc-default-user-name "user" + "Your user name sent to the server when connecting." + :version "24.1" ; changed default + :type 'string + :group 'rcirc) + +(defcustom rcirc-default-full-name "unknown" + "The full name sent to the server when connecting." + :version "24.1" ; changed default + :type 'string + :group 'rcirc) + +(defcustom rcirc-fill-flag t + "Non-nil means line-wrap messages printed in channel buffers." + :type 'boolean + :group 'rcirc) + +(defcustom rcirc-fill-column nil + "Column beyond which automatic line-wrapping should happen. +If nil, use value of `fill-column'. +If a function (e.g., `frame-text-width' or `window-text-width'), +call it to compute the number of columns." + :risky t ; can get funcalled + :type '(choice (const :tag "Value of `fill-column'" nil) + (integer :tag "Number of columns") + (function :tag "Function returning the number of columns")) + :group 'rcirc) + +(defcustom rcirc-fill-prefix nil + "Text to insert before filled lines. +If nil, calculate the prefix dynamically to line up text +underneath each nick." + :type '(choice (const :tag "Dynamic" nil) + (string :tag "Prefix text")) + :group 'rcirc) + +(defvar rcirc-ignore-buffer-activity-flag nil + "If non-nil, ignore activity in this buffer.") +(make-variable-buffer-local 'rcirc-ignore-buffer-activity-flag) + +(defvar rcirc-low-priority-flag nil + "If non-nil, activity in this buffer is considered low priority.") +(make-variable-buffer-local 'rcirc-low-priority-flag) + +(defcustom rcirc-omit-responses + '("JOIN" "PART" "QUIT" "NICK") + "Responses which will be hidden when `rcirc-omit-mode' is enabled." + :type '(repeat string) + :group 'rcirc) + +(defvar rcirc-prompt-start-marker nil) + +(define-minor-mode rcirc-omit-mode + "Toggle the hiding of \"uninteresting\" lines. +With a prefix argument ARG, enable Rcirc-Omit mode if ARG is +positive, and disable it otherwise. If called from Lisp, enable +the mode if ARG is omitted or nil. + +Uninteresting lines are those whose responses are listed in +`rcirc-omit-responses'." + nil " Omit" nil + (if rcirc-omit-mode + (progn + (add-to-invisibility-spec '(rcirc-omit . nil)) + (message "Rcirc-Omit mode enabled")) + (remove-from-invisibility-spec '(rcirc-omit . nil)) + (message "Rcirc-Omit mode disabled")) + (dolist (window (get-buffer-window-list (current-buffer))) + (with-selected-window window + (recenter (when (> (point) rcirc-prompt-start-marker) -1))))) + +(defcustom rcirc-time-format "%H:%M " + "Describes how timestamps are printed. +Used as the first arg to `format-time-string'." + :type 'string + :group 'rcirc) + +(defcustom rcirc-input-ring-size 1024 + "Size of input history ring." + :type 'integer + :group 'rcirc) + +(defcustom rcirc-read-only-flag t + "Non-nil means make text in IRC buffers read-only." + :type 'boolean + :group 'rcirc) + +(defcustom rcirc-buffer-maximum-lines nil + "The maximum size in lines for rcirc buffers. +Channel buffers are truncated from the top to be no greater than this +number. If zero or nil, no truncating is done." + :type '(choice (const :tag "No truncation" nil) + (integer :tag "Number of lines")) + :group 'rcirc) + +(defcustom rcirc-scroll-show-maximum-output t + "If non-nil, scroll buffer to keep the point at the bottom of +the window." + :type 'boolean + :group 'rcirc) + +(defcustom rcirc-authinfo nil + "List of authentication passwords. +Each element of the list is a list with a SERVER-REGEXP string +and a method symbol followed by method specific arguments. + +The valid METHOD symbols are `nickserv', `chanserv' and +`bitlbee'. + +The ARGUMENTS for each METHOD symbol are: + `nickserv': NICK PASSWORD [NICKSERV-NICK] + `chanserv': NICK CHANNEL PASSWORD + `bitlbee': NICK PASSWORD + `quakenet': ACCOUNT PASSWORD + +Examples: + ((\"freenode\" nickserv \"bob\" \"p455w0rd\") + (\"freenode\" chanserv \"bob\" \"#bobland\" \"passwd99\") + (\"bitlbee\" bitlbee \"robert\" \"sekrit\") + (\"dal.net\" nickserv \"bob\" \"sekrit\" \"NickServ@services.dal.net\") + (\"quakenet.org\" quakenet \"bobby\" \"sekrit\"))" + :type '(alist :key-type (string :tag "Server") + :value-type (choice (list :tag "NickServ" + (const nickserv) + (string :tag "Nick") + (string :tag "Password")) + (list :tag "ChanServ" + (const chanserv) + (string :tag "Nick") + (string :tag "Channel") + (string :tag "Password")) + (list :tag "BitlBee" + (const bitlbee) + (string :tag "Nick") + (string :tag "Password")) + (list :tag "QuakeNet" + (const quakenet) + (string :tag "Account") + (string :tag "Password")))) + :group 'rcirc) + +(defcustom rcirc-auto-authenticate-flag t + "Non-nil means automatically send authentication string to server. +See also `rcirc-authinfo'." + :type 'boolean + :group 'rcirc) + +(defcustom rcirc-authenticate-before-join t + "Non-nil means authenticate to services before joining channels. +Currently only works with NickServ on some networks." + :version "24.1" + :type 'boolean + :group 'rcirc) + +(defcustom rcirc-prompt "> " + "Prompt string to use in IRC buffers. + +The following replacements are made: +%n is your nick. +%s is the server. +%t is the buffer target, a channel or a user. + +Setting this alone will not affect the prompt; +use either M-x customize or also call `rcirc-update-prompt'." + :type 'string + :set 'rcirc-set-changed + :initialize 'custom-initialize-default + :group 'rcirc) + +(defcustom rcirc-keywords nil + "List of keywords to highlight in message text." + :type '(repeat string) + :group 'rcirc) + +(defcustom rcirc-ignore-list () + "List of ignored nicks. +Use /ignore to list them, use /ignore NICK to add or remove a nick." + :type '(repeat string) + :group 'rcirc) + +(defvar rcirc-ignore-list-automatic () + "List of ignored nicks added to `rcirc-ignore-list' because of renaming. +When an ignored person renames, their nick is added to both lists. +Nicks will be removed from the automatic list on follow-up renamings or +parts.") + +(defcustom rcirc-bright-nicks nil + "List of nicks to be emphasized. +See `rcirc-bright-nick' face." + :type '(repeat string) + :group 'rcirc) + +(defcustom rcirc-dim-nicks nil + "List of nicks to be deemphasized. +See `rcirc-dim-nick' face." + :type '(repeat string) + :group 'rcirc) + +(define-obsolete-variable-alias 'rcirc-print-hooks + 'rcirc-print-functions "24.3") +(defcustom rcirc-print-functions nil + "Hook run after text is printed. +Called with 5 arguments, PROCESS, SENDER, RESPONSE, TARGET and TEXT." + :type 'hook + :group 'rcirc) + +(defvar rcirc-authenticated-hook nil + "Hook run after successfully authenticated.") + +(defcustom rcirc-always-use-server-buffer-flag nil + "Non-nil means messages without a channel target will go to the server buffer." + :type 'boolean + :group 'rcirc) + +(defcustom rcirc-decode-coding-system 'utf-8 + "Coding system used to decode incoming irc messages. +Set to `undecided' if you want the encoding of the incoming +messages autodetected." + :type 'coding-system + :group 'rcirc) + +(defcustom rcirc-encode-coding-system 'utf-8 + "Coding system used to encode outgoing irc messages." + :type 'coding-system + :group 'rcirc) + +(defcustom rcirc-coding-system-alist nil + "Alist to decide a coding system to use for a channel I/O operation. +The format is ((PATTERN . VAL) ...). +PATTERN is either a string or a cons of strings. +If PATTERN is a string, it is used to match a target. +If PATTERN is a cons of strings, the car part is used to match a +target, and the cdr part is used to match a server. +VAL is either a coding system or a cons of coding systems. +If VAL is a coding system, it is used for both decoding and encoding +messages. +If VAL is a cons of coding systems, the car part is used for decoding, +and the cdr part is used for encoding." + :type '(alist :key-type (choice (string :tag "Channel Regexp") + (cons (string :tag "Channel Regexp") + (string :tag "Server Regexp"))) + :value-type (choice coding-system + (cons (coding-system :tag "Decode") + (coding-system :tag "Encode")))) + :group 'rcirc) + +(defcustom rcirc-multiline-major-mode 'fundamental-mode + "Major-mode function to use in multiline edit buffers." + :type 'function + :group 'rcirc) + +(defcustom rcirc-nick-completion-format "%s: " + "Format string to use in nick completions. + +The format string is only used when completing at the beginning +of a line. The string is passed as the first argument to +`format' with the nickname as the second argument." + :version "24.1" + :type 'string + :group 'rcirc) + +(defcustom rcirc-kill-channel-buffers nil + "When non-nil, kill channel buffers when the server buffer is killed. +Only the channel buffers associated with the server in question +will be killed." + :version "24.3" + :type 'boolean + :group 'rcirc) + +(defvar rcirc-nick nil) + +(defvar rcirc-prompt-end-marker nil) + +(defvar rcirc-nick-table nil) + +(defvar rcirc-recent-quit-alist nil + "Alist of nicks that have recently quit or parted the channel.") + +(defvar rcirc-nick-syntax-table + (let ((table (make-syntax-table text-mode-syntax-table))) + (mapc (lambda (c) (modify-syntax-entry c "w" table)) + "[]\\`_^{|}-") + (modify-syntax-entry ?' "_" table) + table) + "Syntax table which includes all nick characters as word constituents.") + +;; each process has an alist of (target . buffer) pairs +(defvar rcirc-buffer-alist nil) + +(defvar rcirc-activity nil + "List of buffers with unviewed activity.") + +(defvar rcirc-activity-string "" + "String displayed in mode line representing `rcirc-activity'.") +(put 'rcirc-activity-string 'risky-local-variable t) + +(defvar rcirc-server-buffer nil + "The server buffer associated with this channel buffer.") + +(defvar rcirc-target nil + "The channel or user associated with this buffer.") + +(defvar rcirc-urls nil + "List of URLs seen in the current buffer and their start positions.") +(put 'rcirc-urls 'permanent-local t) + +(defvar rcirc-timeout-seconds 600 + "Kill connection after this many seconds if there is no activity.") + +(defconst rcirc-id-string (concat "rcirc on GNU Emacs " emacs-version)) + +(defvar rcirc-startup-channels nil) + +(defvar rcirc-server-name-history nil + "History variable for \\[rcirc] call.") + +(defvar rcirc-server-port-history nil + "History variable for \\[rcirc] call.") + +(defvar rcirc-nick-name-history nil + "History variable for \\[rcirc] call.") + +(defvar rcirc-user-name-history nil + "History variable for \\[rcirc] call.") + +(defvar rcirc-last-message-time nil) + +;;;###autoload +(defun rcirc (arg) + "Connect to all servers in `rcirc-server-alist'. + +Do not connect to a server if it is already connected. + +If ARG is non-nil, instead prompt for connection parameters." + (interactive "P") + (if arg + (let* ((server (completing-read "IRC Server: " + rcirc-server-alist + nil nil + (caar rcirc-server-alist) + 'rcirc-server-name-history)) + (server-plist (cdr (assoc-string server rcirc-server-alist))) + (port (read-string "IRC Port: " + (number-to-string + (or (plist-get server-plist :port) + rcirc-default-port)) + 'rcirc-server-port-history)) + (nick (read-string "IRC Nick: " + (or (plist-get server-plist :nick) + rcirc-default-nick) + 'rcirc-nick-name-history)) + (user-name (read-string "IRC Username: " + (or (plist-get server-plist :user-name) + rcirc-default-user-name) + 'rcirc-user-name-history)) + (password (read-passwd "IRC Password: " nil + (plist-get server-plist :password))) + (channels (split-string + (read-string "IRC Channels: " + (mapconcat 'identity + (plist-get server-plist + :channels) + " ")) + "[, ]+" t)) + (encryption (rcirc-prompt-for-encryption server-plist))) + (rcirc-connect server port nick user-name + rcirc-default-full-name + channels password encryption)) + ;; connect to servers in `rcirc-server-alist' + (let (connected-servers) + (dolist (c rcirc-server-alist) + (let ((server (car c)) + (nick (or (plist-get (cdr c) :nick) rcirc-default-nick)) + (port (or (plist-get (cdr c) :port) rcirc-default-port)) + (user-name (or (plist-get (cdr c) :user-name) + rcirc-default-user-name)) + (full-name (or (plist-get (cdr c) :full-name) + rcirc-default-full-name)) + (channels (plist-get (cdr c) :channels)) + (password (plist-get (cdr c) :password)) + (encryption (plist-get (cdr c) :encryption)) + (server-alias (plist-get (cdr c) :server-alias)) + contact) + (when server + (let (connected) + (dolist (p (rcirc-process-list)) + (when (string= (or server-alias server) (process-name p)) + (setq connected p))) + (if (not connected) + (condition-case nil + (rcirc-connect server port nick user-name + full-name channels password encryption + server-alias) + (quit (message "Quit connecting to %s" + (or server-alias server)))) + (with-current-buffer (process-buffer connected) + (setq contact (process-contact + (get-buffer-process (current-buffer)) :name)) + (setq connected-servers + (cons (if (stringp contact) + contact (or server-alias server)) + connected-servers)))))))) + (when connected-servers + (message "Already connected to %s" + (if (cdr connected-servers) + (concat (mapconcat 'identity (butlast connected-servers) ", ") + ", and " + (car (last connected-servers))) + (car connected-servers))))))) + +;;;###autoload +(defalias 'irc 'rcirc) + + +(defvar rcirc-process-output nil) +(defvar rcirc-topic nil) +(defvar rcirc-keepalive-timer nil) +(defvar rcirc-last-server-message-time nil) +(defvar rcirc-server nil) ; server provided by server +(defvar rcirc-server-name nil) ; server name given by 001 response +(defvar rcirc-timeout-timer nil) +(defvar rcirc-user-authenticated nil) +(defvar rcirc-user-disconnect nil) +(defvar rcirc-connecting nil) +(defvar rcirc-connection-info nil) +(defvar rcirc-process nil) + +;;;###autoload +(defun rcirc-connect (server &optional port nick user-name + full-name startup-channels password encryption + server-alias) + (save-excursion + (message "Connecting to %s..." (or server-alias server)) + (let* ((inhibit-eol-conversion) + (port-number (if port + (if (stringp port) + (string-to-number port) + port) + rcirc-default-port)) + (nick (or nick rcirc-default-nick)) + (user-name (or user-name rcirc-default-user-name)) + (full-name (or full-name rcirc-default-full-name)) + (startup-channels startup-channels) + (process (open-network-stream + (or server-alias server) nil server port-number + :type (or encryption 'plain)))) + ;; set up process + (set-process-coding-system process 'raw-text 'raw-text) + (switch-to-buffer (rcirc-generate-new-buffer-name process nil)) + (set-process-buffer process (current-buffer)) + (rcirc-mode process nil) + (set-process-sentinel process 'rcirc-sentinel) + (set-process-filter process 'rcirc-filter) + + (setq-local rcirc-connection-info + (list server port nick user-name full-name startup-channels + password encryption server-alias)) + (setq-local rcirc-process process) + (setq-local rcirc-server server) + (setq-local rcirc-server-name + (or server-alias server)) ; Update when we get 001 response. + (setq-local rcirc-buffer-alist nil) + (setq-local rcirc-nick-table (make-hash-table :test 'equal)) + (setq-local rcirc-nick nick) + (setq-local rcirc-process-output nil) + (setq-local rcirc-startup-channels startup-channels) + (setq-local rcirc-last-server-message-time (current-time)) + + (setq-local rcirc-timeout-timer nil) + (setq-local rcirc-user-disconnect nil) + (setq-local rcirc-user-authenticated nil) + (setq-local rcirc-connecting t) + + (add-hook 'auto-save-hook 'rcirc-log-write) + + ;; identify + (unless (zerop (length password)) + (rcirc-send-string process (concat "PASS " password))) + (rcirc-send-string process (concat "NICK " nick)) + (rcirc-send-string process "CAP LS 302") + (rcirc-send-string process (concat "USER " user-name + " 0 * :" full-name)) + + ;; setup ping timer if necessary + (unless rcirc-keepalive-timer + (setq rcirc-keepalive-timer + (run-at-time 0 (/ rcirc-timeout-seconds 2) 'rcirc-keepalive))) + + (message "Connecting to %s...done" (or server-alias server)) + + ;; return process object + process))) + +(defmacro with-rcirc-process-buffer (process &rest body) + (declare (indent 1) (debug t)) + `(with-current-buffer (process-buffer ,process) + ,@body)) + +(defmacro with-rcirc-server-buffer (&rest body) + (declare (indent 0) (debug t)) + `(with-current-buffer rcirc-server-buffer + ,@body)) + +(define-obsolete-function-alias 'rcirc-float-time 'float-time "26.1") + +(defun rcirc-prompt-for-encryption (server-plist) + "Prompt the user for the encryption method to use. +SERVER-PLIST is the property list for the server." + (let ((msg "Encryption (default %s): ") + (choices '("plain" "tls")) + (default (or (plist-get server-plist :encryption) + 'plain))) + (intern + (completing-read (format msg default) + choices nil t nil nil (symbol-name default))))) + +(defun rcirc-keepalive () + "Send keep alive pings to active rcirc processes. +Kill processes that have not received a server message since the +last ping." + (if (rcirc-process-list) + (mapc (lambda (process) + (with-rcirc-process-buffer process + (when (not rcirc-connecting) + (rcirc-send-ctcp process + rcirc-nick + (format "KEEPALIVE %f" + (float-time)))))) + (rcirc-process-list)) + ;; no processes, clean up timer + (when (timerp rcirc-keepalive-timer) + (cancel-timer rcirc-keepalive-timer)) + (setq rcirc-keepalive-timer nil))) + +(defun rcirc-handler-ctcp-KEEPALIVE (process _target _sender message) + (with-rcirc-process-buffer process + (setq header-line-format (format "%f" (- (float-time) + (string-to-number message)))))) + +(defvar rcirc-debug-buffer "*rcirc debug*") +(defvar rcirc-debug-flag nil + "If non-nil, write information to `rcirc-debug-buffer'.") +(defun rcirc-debug (process text) + "Add an entry to the debug log including PROCESS and TEXT. +Debug text is written to `rcirc-debug-buffer' if `rcirc-debug-flag' +is non-nil." + (when rcirc-debug-flag + (with-current-buffer (get-buffer-create rcirc-debug-buffer) + (goto-char (point-max)) + (insert (concat + "[" + (format-time-string "%Y-%m-%dT%T ") (process-name process) + "] " + text))))) + +(define-obsolete-variable-alias 'rcirc-sentinel-hooks + 'rcirc-sentinel-functions "24.3") +(defvar rcirc-sentinel-functions nil + "Hook functions called when the process sentinel is called. +Functions are called with PROCESS and SENTINEL arguments.") + +(defcustom rcirc-reconnect-delay 0 + "The minimum interval in seconds between reconnect attempts. +When 0, do not auto-reconnect." + :version "25.1" + :type 'integer + :group 'rcirc) + +(defvar rcirc-last-connect-time nil + "The last time the buffer was connected.") + +(defun rcirc-sentinel (process sentinel) + "Called when PROCESS receives SENTINEL." + (let ((sentinel (replace-regexp-in-string "\n" "" sentinel))) + (rcirc-debug process (format "SENTINEL: %S %S\n" process sentinel)) + (with-rcirc-process-buffer process + (dolist (buffer (cons nil (mapcar 'cdr rcirc-buffer-alist))) + (with-current-buffer (or buffer (current-buffer)) + (rcirc-print process "rcirc.el" "ERROR" rcirc-target + (format "%s: %s (%S)" + (process-name process) + sentinel + (process-status process)) + (not rcirc-target)) + (rcirc-disconnect-buffer))) + (when (and (string= sentinel "deleted") + (< 0 rcirc-reconnect-delay)) + (let ((now (current-time))) + (when (or (null rcirc-last-connect-time) + (< rcirc-reconnect-delay + (float-time (time-subtract now rcirc-last-connect-time)))) + (setq rcirc-last-connect-time now) + (rcirc-cmd-reconnect nil)))) + (run-hook-with-args 'rcirc-sentinel-functions process sentinel)))) + +(defun rcirc-disconnect-buffer (&optional buffer) + (with-current-buffer (or buffer (current-buffer)) + ;; set rcirc-target to nil for each channel so cleanup + ;; doesn't happen when we reconnect + (setq rcirc-target nil) + (setq mode-line-process ":disconnected"))) + +(defun rcirc-process-list () + "Return a list of rcirc processes." + (let (ps) + (mapc (lambda (p) + (when (buffer-live-p (process-buffer p)) + (with-rcirc-process-buffer p + (when (eq major-mode 'rcirc-mode) + (setq ps (cons p ps)))))) + (process-list)) + ps)) + +(define-obsolete-variable-alias 'rcirc-receive-message-hooks + 'rcirc-receive-message-functions "24.3") +(defvar rcirc-receive-message-functions nil + "Hook functions run when a message is received from server. +Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.") +(defun rcirc-filter (process output) + "Called when PROCESS receives OUTPUT." + (rcirc-debug process output) + (rcirc-reschedule-timeout process) + (with-rcirc-process-buffer process + (setq rcirc-last-server-message-time (current-time)) + (setq rcirc-process-output (concat rcirc-process-output output)) + (when (= ?\n (aref rcirc-process-output + (1- (length rcirc-process-output)))) + (let ((lines (split-string rcirc-process-output "[\n\r]" t))) + (setq rcirc-process-output nil) + (dolist (line lines) + (rcirc-process-server-response process line)))))) + +(defun rcirc-reschedule-timeout (process) + (with-rcirc-process-buffer process + (when (not rcirc-connecting) + (with-rcirc-process-buffer process + (when rcirc-timeout-timer (cancel-timer rcirc-timeout-timer)) + (setq rcirc-timeout-timer (run-at-time rcirc-timeout-seconds nil + 'rcirc-delete-process + process)))))) + +(defun rcirc-delete-process (process) + (delete-process process)) + +(defvar rcirc-trap-errors-flag t) +(defun rcirc-process-server-response (process text) + (if rcirc-trap-errors-flag + (condition-case err + (rcirc-process-server-response-1 process text) + (error + (rcirc-print process "RCIRC" "ERROR" nil + (format "\"%s\" %s" text err) t))) + (rcirc-process-server-response-1 process text))) + +(defun rcirc-handle-message-tags (tags) + (if-let* ((time (cdr (assoc "time" tags))) + (timestamp (floor (float-time (date-to-time time))))) + (setq rcirc-last-message-time timestamp))) + +(defun rcirc-parse-tags (tags) + "Parse TAGS message prefix." + (mapcar (lambda (tag) + (let ((p (split-string tag "="))) + `(,(car p) . ,(cadr p)))) + (split-string tags ";"))) + +(defun rcirc-process-server-response-1 (process text) + + ;; attempt to extract and handle IRCv3 message tags (which contain server-time) + (if (string-match "^\\(@\\([^ ]+\\) \\)?\\(\\(:[^ ]+ \\)?[^ ]+ .+\\)$" text) + (let ((tags (match-string 2 text)) + (rest (match-string 3 text))) + (when tags + (rcirc-handle-message-tags (rcirc-parse-tags tags))) + (setq text rest))) + + (if (string-match "^\\(:\\([^ ]+\\) \\)?\\([^ ]+\\) \\(.+\\)$" text) + (let* ((user (match-string 2 text)) + (sender (rcirc-user-nick user)) + (cmd (match-string 3 text)) + (args (match-string 4 text)) + (handler (intern-soft (concat "rcirc-handler-" cmd)))) + (string-match "^\\([^:]*\\):?\\(.+\\)?$" args) + (let* ((args1 (match-string 1 args)) + (args2 (match-string 2 args)) + (args (delq nil (append (split-string args1 " " t) + (list args2))))) + (if (not (fboundp handler)) + (rcirc-handler-generic process cmd sender args text) + (funcall handler process sender args text)) + (run-hook-with-args 'rcirc-receive-message-functions + process cmd sender args text))) + (message "UNHANDLED: %s" text))) + +(defvar rcirc-responses-no-activity '("305" "306") + "Responses that don't trigger activity in the mode-line indicator.") + +(defun rcirc-handler-generic (process response sender args _text) + "Generic server response handler." + (rcirc-print process sender response nil + (mapconcat 'identity (cdr args) " ") + (not (member response rcirc-responses-no-activity)))) + +(defun rcirc--connection-open-p (process) + (memq (process-status process) '(run open))) + +(defun rcirc-send-string (process string) + "Send PROCESS a STRING plus a newline." + (let ((string (concat (encode-coding-string string rcirc-encode-coding-system) + "\n"))) + (unless (rcirc--connection-open-p process) + (error "Network connection to %s is not open" + (process-name process))) + (rcirc-debug process string) + (process-send-string process string))) + +(defun rcirc-send-privmsg (process target string) + (rcirc-send-string process (format "PRIVMSG %s :%s" target string))) + +(defun rcirc-send-ctcp (process target request &optional args) + (let ((args (if args (concat " " args) ""))) + (rcirc-send-privmsg process target + (format "\C-a%s%s\C-a" request args)))) + +(defun rcirc-buffer-process (&optional buffer) + "Return the process associated with channel BUFFER. +With no argument or nil as argument, use the current buffer." + (let ((buffer (or buffer (and (buffer-live-p rcirc-server-buffer) + rcirc-server-buffer)))) + (if buffer + (with-current-buffer buffer rcirc-process) + rcirc-process))) + +(defun rcirc-server-name (process) + "Return PROCESS server name, given by the 001 response." + (with-rcirc-process-buffer process + (or rcirc-server-name + (warn "server name for process %S unknown" process)))) + +(defun rcirc-nick (process) + "Return PROCESS nick." + (with-rcirc-process-buffer process + (or rcirc-nick rcirc-default-nick))) + +(defun rcirc-buffer-nick (&optional buffer) + "Return the nick associated with BUFFER. +With no argument or nil as argument, use the current buffer." + (with-current-buffer (or buffer (current-buffer)) + (with-current-buffer rcirc-server-buffer + (or rcirc-nick rcirc-default-nick)))) + +(defvar rcirc-max-message-length 420 + "Messages longer than this value will be split.") + +(defun rcirc-split-message (message) + "Split MESSAGE into chunks within `rcirc-max-message-length'." + ;; `rcirc-encode-coding-system' can have buffer-local value. + (let ((encoding rcirc-encode-coding-system)) + (with-temp-buffer + (insert message) + (goto-char (point-min)) + (let (result) + (while (not (eobp)) + (goto-char (or (byte-to-position rcirc-max-message-length) + (point-max))) + ;; max message length is 512 including CRLF + (while (and (not (bobp)) + (> (length (encode-coding-region + (point-min) (point) encoding t)) + rcirc-max-message-length)) + (forward-char -1)) + (push (delete-and-extract-region (point-min) (point)) result)) + (nreverse result))))) + +(defun rcirc-send-message (process target message &optional noticep silent) + "Send TARGET associated with PROCESS a privmsg with text MESSAGE. +If NOTICEP is non-nil, send a notice instead of privmsg. +If SILENT is non-nil, do not print the message in any irc buffer." + (let ((response (if noticep "NOTICE" "PRIVMSG"))) + (rcirc-get-buffer-create process target) + (dolist (msg (rcirc-split-message message)) + (rcirc-send-string process (concat response " " target " :" msg)) + (unless silent + (rcirc-print process (rcirc-nick process) response target msg))))) + +(defvar rcirc-input-ring nil) +(defvar rcirc-input-ring-index 0) + +(defun rcirc-prev-input-string (arg) + (ring-ref rcirc-input-ring (+ rcirc-input-ring-index arg))) + +(defun rcirc-insert-prev-input () + (interactive) + (when (<= rcirc-prompt-end-marker (point)) + (delete-region rcirc-prompt-end-marker (point-max)) + (insert (rcirc-prev-input-string 0)) + (setq rcirc-input-ring-index (1+ rcirc-input-ring-index)))) + +(defun rcirc-insert-next-input () + (interactive) + (when (<= rcirc-prompt-end-marker (point)) + (delete-region rcirc-prompt-end-marker (point-max)) + (setq rcirc-input-ring-index (1- rcirc-input-ring-index)) + (insert (rcirc-prev-input-string -1)))) + +(defvar rcirc-server-commands + '("/admin" "/away" "/connect" "/die" "/error" "/info" + "/invite" "/ison" "/join" "/kick" "/kill" "/links" + "/list" "/lusers" "/mode" "/motd" "/names" "/nick" + "/notice" "/oper" "/part" "/pass" "/ping" "/pong" + "/privmsg" "/quit" "/rehash" "/restart" "/service" "/servlist" + "/server" "/squery" "/squit" "/stats" "/summon" "/time" + "/topic" "/trace" "/user" "/userhost" "/users" "/version" + "/wallops" "/who" "/whois" "/whowas") + "A list of user commands by IRC server. +The value defaults to RFCs 1459 and 2812.") + +;; /me and /ctcp are not defined by `defun-rcirc-command'. +(defvar rcirc-client-commands '("/me" "/ctcp") + "A list of user commands defined by IRC client rcirc. +The list is updated automatically by `defun-rcirc-command'.") + +(defun rcirc-completion-at-point () + "Function used for `completion-at-point-functions' in `rcirc-mode'." + (and (rcirc-looking-at-input) + (let* ((beg (save-excursion + ;; On some networks it is common to message or + ;; mention someone using @nick instead of just + ;; nick. + (if (re-search-backward "[[:space:]@]" rcirc-prompt-end-marker t) + (1+ (point)) + rcirc-prompt-end-marker))) + (table (if (and (= beg rcirc-prompt-end-marker) + (eq (char-after beg) ?/)) + (delete-dups + (nconc (sort (copy-sequence rcirc-client-commands) + 'string-lessp) + (sort (copy-sequence rcirc-server-commands) + 'string-lessp))) + (rcirc-channel-nicks (rcirc-buffer-process) + rcirc-target)))) + (list beg (point) table)))) + +(defvar rcirc-completions nil) +(defvar rcirc-completion-start nil) + +(defun rcirc-complete () + "Cycle through completions from list of nicks in channel or IRC commands. +IRC command completion is performed only if `/' is the first input char." + (interactive) + (unless (rcirc-looking-at-input) + (error "Point not located after rcirc prompt")) + (if (eq last-command this-command) + (setq rcirc-completions + (append (cdr rcirc-completions) (list (car rcirc-completions)))) + (let ((completion-ignore-case t) + (table (rcirc-completion-at-point))) + (setq rcirc-completion-start (car table)) + (setq rcirc-completions + (and rcirc-completion-start + (all-completions (buffer-substring rcirc-completion-start + (cadr table)) + (nth 2 table)))))) + (let ((completion (car rcirc-completions))) + (when completion + (delete-region rcirc-completion-start (point)) + (insert + (cond + ((= (aref completion 0) ?/) (concat completion " ")) + ((= rcirc-completion-start rcirc-prompt-end-marker) + (format rcirc-nick-completion-format completion)) + (t completion)))))) + +(defun set-rcirc-decode-coding-system (coding-system) + "Set the decode coding system used in this channel." + (interactive "zCoding system for incoming messages: ") + (setq-local rcirc-decode-coding-system coding-system)) + +(defun set-rcirc-encode-coding-system (coding-system) + "Set the encode coding system used in this channel." + (interactive "zCoding system for outgoing messages: ") + (setq-local rcirc-encode-coding-system coding-system)) + +(defvar rcirc-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'rcirc-send-input) + (define-key map (kbd "M-p") 'rcirc-insert-prev-input) + (define-key map (kbd "M-n") 'rcirc-insert-next-input) + (define-key map (kbd "TAB") 'rcirc-complete) + (define-key map (kbd "C-c C-b") 'rcirc-browse-url) + (define-key map (kbd "C-c C-c") 'rcirc-edit-multiline) + (define-key map (kbd "C-c C-j") 'rcirc-cmd-join) + (define-key map (kbd "C-c C-k") 'rcirc-cmd-kick) + (define-key map (kbd "C-c C-l") 'rcirc-toggle-low-priority) + (define-key map (kbd "C-c C-d") 'rcirc-cmd-mode) + (define-key map (kbd "C-c C-m") 'rcirc-cmd-msg) + (define-key map (kbd "C-c C-r") 'rcirc-cmd-nick) ; rename + (define-key map (kbd "C-c C-o") 'rcirc-omit-mode) + (define-key map (kbd "C-c C-p") 'rcirc-cmd-part) + (define-key map (kbd "C-c C-q") 'rcirc-cmd-query) + (define-key map (kbd "C-c C-t") 'rcirc-cmd-topic) + (define-key map (kbd "C-c C-n") 'rcirc-cmd-names) + (define-key map (kbd "C-c C-w") 'rcirc-cmd-whois) + (define-key map (kbd "C-c C-x") 'rcirc-cmd-quit) + (define-key map (kbd "C-c TAB") ; C-i + 'rcirc-toggle-ignore-buffer-activity) + (define-key map (kbd "C-c C-s") 'rcirc-switch-to-server-buffer) + (define-key map (kbd "C-c C-a") 'rcirc-jump-to-first-unread-line) + map) + "Keymap for rcirc mode.") + +(defvar rcirc-short-buffer-name nil + "Generated abbreviation to use to indicate buffer activity.") + +(defvar rcirc-mode-hook nil + "Hook run when setting up rcirc buffer.") + +(defvar rcirc-last-post-time nil) + +(defvar rcirc-log-alist nil + "Alist of lines to log to disk when `rcirc-log-flag' is non-nil. +Each element looks like (FILENAME . TEXT).") + +(defvar rcirc-current-line 0 + "The current number of responses printed in this channel. +This number is independent of the number of lines in the buffer.") + +(defun rcirc-mode (process target) + ;; FIXME: Use define-derived-mode. + "Major mode for IRC channel buffers. + +\\{rcirc-mode-map}" + (kill-all-local-variables) + (use-local-map rcirc-mode-map) + (setq mode-name "rcirc") + (setq major-mode 'rcirc-mode) + (setq mode-line-process nil) + + (setq-local rcirc-input-ring + ;; If rcirc-input-ring is already a ring with desired + ;; size do not re-initialize. + (if (and (ring-p rcirc-input-ring) + (= (ring-size rcirc-input-ring) + rcirc-input-ring-size)) + rcirc-input-ring + (make-ring rcirc-input-ring-size))) + (setq-local rcirc-server-buffer (process-buffer process)) + (setq-local rcirc-target target) + (setq-local rcirc-topic nil) + (setq-local rcirc-last-post-time (current-time)) + (setq-local fill-paragraph-function 'rcirc-fill-paragraph) + (setq-local rcirc-recent-quit-alist nil) + (setq-local rcirc-current-line 0) + (setq-local rcirc-last-connect-time (current-time)) + + (use-hard-newlines t) + (setq-local rcirc-short-buffer-name nil) + (setq-local rcirc-urls nil) + + ;; setup for omitting responses + (setq buffer-invisibility-spec '()) + (setq buffer-display-table (make-display-table)) + (set-display-table-slot buffer-display-table 4 + (let ((glyph (make-glyph-code + ?. 'font-lock-keyword-face))) + (make-vector 3 glyph))) + + (dolist (i rcirc-coding-system-alist) + (let ((chan (if (consp (car i)) (caar i) (car i))) + (serv (if (consp (car i)) (cdar i) ""))) + (when (and (string-match chan (or target "")) + (string-match serv (rcirc-server-name process))) + (setq-local rcirc-decode-coding-system + (if (consp (cdr i)) (cadr i) (cdr i))) + (setq-local rcirc-encode-coding-system + (if (consp (cdr i)) (cddr i) (cdr i)))))) + + ;; setup the prompt and markers + (setq-local rcirc-prompt-start-marker (point-max-marker)) + (setq-local rcirc-prompt-end-marker (point-max-marker)) + (rcirc-update-prompt) + (goto-char rcirc-prompt-end-marker) + + (setq-local overlay-arrow-position (make-marker)) + + ;; if the user changes the major mode or kills the buffer, there is + ;; cleanup work to do + (add-hook 'change-major-mode-hook 'rcirc-change-major-mode-hook nil t) + (add-hook 'kill-buffer-hook 'rcirc-kill-buffer-hook nil t) + + ;; add to buffer list, and update buffer abbrevs + (when target ; skip server buffer + (let ((buffer (current-buffer))) + (with-rcirc-process-buffer process + (setq rcirc-buffer-alist (cons (cons target buffer) + rcirc-buffer-alist)))) + (rcirc-update-short-buffer-names)) + + (add-hook 'completion-at-point-functions + 'rcirc-completion-at-point nil 'local) + + (run-mode-hooks 'rcirc-mode-hook)) + +(defun rcirc-update-prompt (&optional all) + "Reset the prompt string in the current buffer. + +If ALL is non-nil, update prompts in all IRC buffers." + (if all + (mapc (lambda (process) + (mapc (lambda (buffer) + (with-current-buffer buffer + (rcirc-update-prompt))) + (with-rcirc-process-buffer process + (mapcar 'cdr rcirc-buffer-alist)))) + (rcirc-process-list)) + (let ((inhibit-read-only t) + (prompt (or rcirc-prompt ""))) + (mapc (lambda (rep) + (setq prompt + (replace-regexp-in-string (car rep) (cdr rep) prompt))) + (list (cons "%n" (rcirc-buffer-nick)) + (cons "%s" (with-rcirc-server-buffer rcirc-server-name)) + (cons "%t" (or rcirc-target "")))) + (save-excursion + (delete-region rcirc-prompt-start-marker rcirc-prompt-end-marker) + (goto-char rcirc-prompt-start-marker) + (let ((start (point))) + (insert-before-markers prompt) + (set-marker rcirc-prompt-start-marker start) + (when (not (zerop (- rcirc-prompt-end-marker + rcirc-prompt-start-marker))) + (add-text-properties rcirc-prompt-start-marker + rcirc-prompt-end-marker + (list 'face 'rcirc-prompt + 'read-only t 'field t + 'front-sticky t 'rear-nonsticky t)))))))) + +(defun rcirc-set-changed (option value) + "Set OPTION to VALUE and do updates after a customization change." + (set-default option value) + (cond ((eq option 'rcirc-prompt) + (rcirc-update-prompt 'all)) + (t + (error "Bad option %s" option)))) + +(defun rcirc-channel-p (target) + "Return t if TARGET is a channel name." + (and target + (not (zerop (length target))) + (or (eq (aref target 0) ?#) + (eq (aref target 0) ?&)))) + +(defcustom rcirc-log-directory "~/.emacs.d/rcirc-log" + "Directory to keep IRC logfiles." + :type 'directory + :group 'rcirc) + +(defcustom rcirc-log-flag nil + "Non-nil means log IRC activity to disk. +Logfiles are kept in `rcirc-log-directory'." + :type 'boolean + :group 'rcirc) + +(defun rcirc-kill-buffer-hook () + "Part the channel when killing an rcirc buffer. + +If `rcirc-kill-channel-buffers' is non-nil and the killed buffer +is a server buffer, kills all of the channel buffers associated +with it." + (when (eq major-mode 'rcirc-mode) + (when (and rcirc-log-flag + rcirc-log-directory) + (rcirc-log-write)) + (rcirc-clean-up-buffer "Killed buffer") + (when (and rcirc-buffer-alist ;; it's a server buffer + rcirc-kill-channel-buffers) + (dolist (channel rcirc-buffer-alist) + (kill-buffer (cdr channel)))))) + +(defun rcirc-change-major-mode-hook () + "Part the channel when changing the major-mode." + (rcirc-clean-up-buffer "Changed major mode")) + +(defun rcirc-clean-up-buffer (reason) + (let ((buffer (current-buffer))) + (rcirc-clear-activity buffer) + (when (and (rcirc-buffer-process) + (rcirc--connection-open-p (rcirc-buffer-process))) + (with-rcirc-server-buffer + (setq rcirc-buffer-alist + (rassq-delete-all buffer rcirc-buffer-alist))) + (rcirc-update-short-buffer-names) + (if (rcirc-channel-p rcirc-target) + (rcirc-send-string (rcirc-buffer-process) + (concat "PART " rcirc-target " :" reason)) + (when rcirc-target + (rcirc-remove-nick-channel (rcirc-buffer-process) + (rcirc-buffer-nick) + rcirc-target)))) + (setq rcirc-target nil))) + +(defun rcirc-generate-new-buffer-name (process target) + "Return a buffer name based on PROCESS and TARGET. +This is used for the initial name given to IRC buffers." + (substring-no-properties + (if target + (concat target "@" (process-name process)) + (concat "*" (process-name process) "*")))) + +(defun rcirc-get-buffer (process target &optional server) + "Return the buffer associated with the PROCESS and TARGET. + +If optional argument SERVER is non-nil, return the server buffer +if there is no existing buffer for TARGET, otherwise return nil." + (with-rcirc-process-buffer process + (if (null target) + (current-buffer) + (let ((buffer (cdr (assoc-string target rcirc-buffer-alist t)))) + (or buffer (when server (current-buffer))))))) + +(defun rcirc-get-buffer-create (process target) + "Return the buffer associated with the PROCESS and TARGET. +Create the buffer if it doesn't exist." + (let ((buffer (rcirc-get-buffer process target))) + (if (and buffer (buffer-live-p buffer)) + (with-current-buffer buffer + (when (not rcirc-target) + (setq rcirc-target target)) + buffer) + ;; create the buffer + (with-rcirc-process-buffer process + (let ((new-buffer (get-buffer-create + (rcirc-generate-new-buffer-name process target)))) + (with-current-buffer new-buffer + (rcirc-mode process target) + (rcirc-put-nick-channel process (rcirc-nick process) target + rcirc-current-line)) + new-buffer))))) + +(defun rcirc-send-input () + "Send input to target associated with the current buffer." + (interactive) + (if (< (point) rcirc-prompt-end-marker) + ;; copy the line down to the input area + (progn + (forward-line 0) + (let ((start (if (eq (point) (point-min)) + (point) + (if (get-text-property (1- (point)) 'hard) + (point) + (previous-single-property-change (point) 'hard)))) + (end (next-single-property-change (1+ (point)) 'hard))) + (goto-char (point-max)) + (insert (replace-regexp-in-string + "\n\\s-+" " " + (buffer-substring-no-properties start end))))) + ;; process input + (goto-char (point-max)) + (when (not (equal 0 (- (point) rcirc-prompt-end-marker))) + ;; delete a trailing newline + (when (eq (point) (point-at-bol)) + (delete-char -1)) + (let ((input (buffer-substring-no-properties + rcirc-prompt-end-marker (point)))) + (dolist (line (split-string input "\n")) + (rcirc-process-input-line line)) + ;; add to input-ring + (save-excursion + (ring-insert rcirc-input-ring input) + (setq rcirc-input-ring-index 0)))))) + +(defun rcirc-fill-paragraph (&optional justify) + (interactive "P") + (when (> (point) rcirc-prompt-end-marker) + (save-restriction + (narrow-to-region rcirc-prompt-end-marker (point-max)) + (let ((fill-column rcirc-max-message-length)) + (fill-region (point-min) (point-max) justify))))) + +(defun rcirc-process-input-line (line) + (if (string-match "^/\\([^ ]+\\) ?\\(.*\\)$" line) + (rcirc-process-command (match-string 1 line) + (match-string 2 line) + line) + (rcirc-process-message line))) + +(defun rcirc-process-message (line) + (if (not rcirc-target) + (message "Not joined (no target)") + (delete-region rcirc-prompt-end-marker (point)) + (rcirc-send-message (rcirc-buffer-process) rcirc-target line) + (setq rcirc-last-post-time (current-time)))) + +(defun rcirc-process-command (command args line) + (if (eq (aref command 0) ?/) + ;; "//text" will send "/text" as a message + (rcirc-process-message (substring line 1)) + (let ((fun (intern-soft (concat "rcirc-cmd-" command))) + (process (rcirc-buffer-process))) + (newline) + (with-current-buffer (current-buffer) + (delete-region rcirc-prompt-end-marker (point)) + (if (string= command "me") + (rcirc-print process (rcirc-buffer-nick) + "ACTION" rcirc-target args) + (rcirc-print process (rcirc-buffer-nick) + "COMMAND" rcirc-target line)) + (set-marker rcirc-prompt-end-marker (point)) + (if (fboundp fun) + (funcall fun args process rcirc-target) + (rcirc-send-string process + (concat command " :" args))))))) + +(defvar rcirc-parent-buffer nil) +(make-variable-buffer-local 'rcirc-parent-buffer) +(put 'rcirc-parent-buffer 'permanent-local t) +(defvar rcirc-window-configuration nil) +(defun rcirc-edit-multiline () + "Move current edit to a dedicated buffer." + (interactive) + (let ((pos (1+ (- (point) rcirc-prompt-end-marker)))) + (goto-char (point-max)) + (let ((text (buffer-substring-no-properties rcirc-prompt-end-marker + (point))) + (parent (buffer-name))) + (delete-region rcirc-prompt-end-marker (point)) + (setq rcirc-window-configuration (current-window-configuration)) + (pop-to-buffer (concat "*multiline " parent "*")) + (funcall rcirc-multiline-major-mode) + (rcirc-multiline-minor-mode 1) + (setq rcirc-parent-buffer parent) + (insert text) + (and (> pos 0) (goto-char pos)) + (message "Type C-c C-c to return text to %s, or C-c C-k to cancel" parent)))) + +(defvar rcirc-multiline-minor-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-c") 'rcirc-multiline-minor-submit) + (define-key map (kbd "C-x C-s") 'rcirc-multiline-minor-submit) + (define-key map (kbd "C-c C-k") 'rcirc-multiline-minor-cancel) + (define-key map (kbd "ESC ESC ESC") 'rcirc-multiline-minor-cancel) + map) + "Keymap for multiline mode in rcirc.") + +(define-minor-mode rcirc-multiline-minor-mode + "Minor mode for editing multiple lines in rcirc. +With a prefix argument ARG, enable the mode if ARG is positive, +and disable it otherwise. If called from Lisp, enable the mode +if ARG is omitted or nil." + :init-value nil + :lighter " rcirc-mline" + :keymap rcirc-multiline-minor-mode-map + :global nil + :group 'rcirc + (setq fill-column rcirc-max-message-length)) + +(defun rcirc-multiline-minor-submit () + "Send the text in buffer back to parent buffer." + (interactive) + (untabify (point-min) (point-max)) + (let ((text (buffer-substring (point-min) (point-max))) + (buffer (current-buffer)) + (pos (point))) + (set-buffer rcirc-parent-buffer) + (goto-char (point-max)) + (insert text) + (kill-buffer buffer) + (set-window-configuration rcirc-window-configuration) + (goto-char (+ rcirc-prompt-end-marker (1- pos))))) + +(defun rcirc-multiline-minor-cancel () + "Cancel the multiline edit." + (interactive) + (kill-buffer (current-buffer)) + (set-window-configuration rcirc-window-configuration)) + +(defun rcirc-any-buffer (process) + "Return a buffer for PROCESS, either the one selected or the process buffer." + (if rcirc-always-use-server-buffer-flag + (process-buffer process) + (let ((buffer (window-buffer))) + (if (and buffer + (with-current-buffer buffer + (and (eq major-mode 'rcirc-mode) + (eq (rcirc-buffer-process) process)))) + buffer + (process-buffer process))))) + +(defcustom rcirc-response-formats + '(("PRIVMSG" . "<%N> %m") + ("NOTICE" . "-%N- %m") + ("ACTION" . "[%N %m]") + ("COMMAND" . "%m") + ("ERROR" . "%fw!!! %m") + (t . "%fp*** %fs%n %r %m")) + "An alist of formats used for printing responses. +The format is looked up using the response-type as a key; +if no match is found, the default entry (with a key of t) is used. + +The entry's value part should be a string, which is inserted with +the of the following escape sequences replaced by the described values: + + %m The message text + %n The sender's nick + %N The sender's nick (with face `rcirc-my-nick' or `rcirc-other-nick') + %r The response-type + %t The target + %fw Following text uses the face `font-lock-warning-face' + %fp Following text uses the face `rcirc-server-prefix' + %fs Following text uses the face `rcirc-server' + %f[FACE] Following text uses the face FACE + %f- Following text uses the default face + %% A literal `%' character" + :type '(alist :key-type (choice (string :tag "Type") + (const :tag "Default" t)) + :value-type string) + :group 'rcirc) + +(defun rcirc-format-response-string (process sender response target text) + "Return a nicely-formatted response string, incorporating TEXT +\(and perhaps other arguments). The specific formatting used +is found by looking up RESPONSE in `rcirc-response-formats'." + (with-temp-buffer + (insert (or (cdr (assoc response rcirc-response-formats)) + (cdr (assq t rcirc-response-formats)))) + (goto-char (point-min)) + (let ((start (point-min)) + (sender (if (or (not sender) + (string= (rcirc-server-name process) sender)) + "" + sender)) + face) + (while (re-search-forward "%\\(\\(f\\(.\\)\\)\\|\\(.\\)\\)" nil t) + (rcirc-add-face start (match-beginning 0) face) + (setq start (match-beginning 0)) + (replace-match + (cl-case (aref (match-string 1) 0) + (?f (setq face + (cl-case (string-to-char (match-string 3)) + (?w 'font-lock-warning-face) + (?p 'rcirc-server-prefix) + (?s 'rcirc-server) + (t nil))) + "") + (?n sender) + (?N (let ((my-nick (rcirc-nick process))) + (save-match-data + (with-syntax-table rcirc-nick-syntax-table + (rcirc-facify sender + (cond ((string= sender my-nick) + 'rcirc-my-nick) + ((and rcirc-bright-nicks + (string-match + (regexp-opt rcirc-bright-nicks + 'words) + sender)) + 'rcirc-bright-nick) + ((and rcirc-dim-nicks + (string-match + (regexp-opt rcirc-dim-nicks + 'words) + sender)) + 'rcirc-dim-nick) + (t + 'rcirc-other-nick))))))) + (?m (propertize text 'rcirc-text text)) + (?r response) + (?t (or target "")) + (t (concat "UNKNOWN CODE:" (match-string 0)))) + t t nil 0) + (rcirc-add-face (match-beginning 0) (match-end 0) face)) + (rcirc-add-face start (match-beginning 0) face)) + (buffer-substring (point-min) (point-max)))) + +(defun rcirc-target-buffer (process sender response target _text) + "Return a buffer to print the server response." + (cl-assert (not (bufferp target))) + (with-rcirc-process-buffer process + (cond ((not target) + (rcirc-any-buffer process)) + ((not (rcirc-channel-p target)) + ;; message from another user + (if (or (string= response "PRIVMSG") + (string= response "ACTION")) + (rcirc-get-buffer-create process (if (string= sender rcirc-nick) + target + sender)) + (rcirc-get-buffer process target t))) + ((or (rcirc-get-buffer process target) + (rcirc-any-buffer process)))))) + +(defvar rcirc-activity-types nil) +(make-variable-buffer-local 'rcirc-activity-types) +(defvar rcirc-last-sender nil) +(make-variable-buffer-local 'rcirc-last-sender) + +(defcustom rcirc-omit-threshold 100 + "Number of lines since last activity from a nick before `rcirc-omit-responses' are omitted." + :type 'integer + :group 'rcirc) + +(defcustom rcirc-log-process-buffers nil + "Non-nil if rcirc process buffers should be logged to disk." + :group 'rcirc + :type 'boolean + :version "24.1") + +(defun rcirc-last-quit-line (process nick target) + "Return the line number where NICK left TARGET. +Returns nil if the information is not recorded." + (let ((chanbuf (rcirc-get-buffer process target))) + (when chanbuf + (cdr (assoc-string nick (with-current-buffer chanbuf + rcirc-recent-quit-alist)))))) + +(defun rcirc-last-line (process nick target) + "Return the line from the last activity from NICK in TARGET." + (let ((line (or (cdr (assoc-string target + (gethash nick (with-rcirc-server-buffer + rcirc-nick-table)) t)) + (rcirc-last-quit-line process nick target)))) + (if line + line + ;;(message "line is nil for %s in %s" nick target) + nil))) + +(defun rcirc-elapsed-lines (process nick target) + "Return the number of lines since activity from NICK in TARGET." + (let ((last-activity-line (rcirc-last-line process nick target))) + (when (and last-activity-line + (> last-activity-line 0)) + (- rcirc-current-line last-activity-line)))) + +(defvar rcirc-markup-text-functions + '(rcirc-markup-attributes + rcirc-markup-my-nick + rcirc-markup-urls + rcirc-markup-keywords + rcirc-markup-bright-nicks) + + "List of functions used to manipulate text before it is printed. + +Each function takes two arguments, SENDER, and RESPONSE. The +buffer is narrowed with the text to be printed and the point is +at the beginning of the `rcirc-text' propertized text.") + +(defun rcirc-print (process sender response target text &optional activity) + "Print TEXT in the buffer associated with TARGET. +Format based on SENDER and RESPONSE. If ACTIVITY is non-nil, +record activity." + (or text (setq text "")) + (unless (and (or (member sender rcirc-ignore-list) + (member (with-syntax-table rcirc-nick-syntax-table + (when (string-match "^\\([^/]\\w*\\)[:,]" text) + (match-string 1 text))) + rcirc-ignore-list)) + ;; do not ignore if we sent the message + (not (string= sender (rcirc-nick process)))) + (let* ((buffer (rcirc-target-buffer process sender response target text)) + (inhibit-read-only t)) + (with-current-buffer buffer + (let ((moving (= (point) rcirc-prompt-end-marker)) + (old-point (point-marker)) + (fill-start (marker-position rcirc-prompt-start-marker))) + + (setq text (decode-coding-string text rcirc-decode-coding-system)) + (unless (string= sender (rcirc-nick process)) + ;; mark the line with overlay arrow + (unless (or (marker-position overlay-arrow-position) + (get-buffer-window (current-buffer)) + (member response rcirc-omit-responses)) + (set-marker overlay-arrow-position + (marker-position rcirc-prompt-start-marker)))) + + ;; temporarily set the marker insertion-type because + ;; insert-before-markers results in hidden text in new buffers + (goto-char rcirc-prompt-start-marker) + (set-marker-insertion-type rcirc-prompt-start-marker t) + (set-marker-insertion-type rcirc-prompt-end-marker t) + + (let ((start (point))) + (insert (rcirc-format-response-string process sender response nil + text) + (propertize "\n" 'hard t)) + + ;; squeeze spaces out of text before rcirc-text + (fill-region fill-start + (1- (or (next-single-property-change fill-start + 'rcirc-text) + rcirc-prompt-end-marker))) + + ;; run markup functions + (save-excursion + (save-restriction + (narrow-to-region start rcirc-prompt-start-marker) + (goto-char (or (next-single-property-change start 'rcirc-text) + (point))) + (when (rcirc-buffer-process) + (save-excursion (rcirc-markup-timestamp sender response)) + (dolist (fn rcirc-markup-text-functions) + (save-excursion (funcall fn sender response))) + (when rcirc-fill-flag + (save-excursion (rcirc-markup-fill sender response)))) + + (when rcirc-read-only-flag + (add-text-properties (point-min) (point-max) + '(read-only t front-sticky t)))) + ;; make text omittable + (let ((last-activity-lines (rcirc-elapsed-lines process sender target))) + (if (and (not (string= (rcirc-nick process) sender)) + (member response rcirc-omit-responses) + (or (not last-activity-lines) + (< rcirc-omit-threshold last-activity-lines))) + (put-text-property (1- start) (1- rcirc-prompt-start-marker) + 'invisible 'rcirc-omit) + ;; otherwise increment the line count + (setq rcirc-current-line (1+ rcirc-current-line)))))) + + (set-marker-insertion-type rcirc-prompt-start-marker nil) + (set-marker-insertion-type rcirc-prompt-end-marker nil) + + ;; truncate buffer if it is very long + (save-excursion + (when (and rcirc-buffer-maximum-lines + (> rcirc-buffer-maximum-lines 0) + (= (forward-line (- rcirc-buffer-maximum-lines)) 0)) + (delete-region (point-min) (point)))) + + ;; set the window point for buffers show in windows + (walk-windows (lambda (w) + (when (and (not (eq (selected-window) w)) + (eq (current-buffer) + (window-buffer w)) + (>= (window-point w) + rcirc-prompt-end-marker)) + (set-window-point w (point-max)))) + nil t) + + ;; restore the point + (goto-char (if moving rcirc-prompt-end-marker old-point)) + + ;; keep window on bottom line if it was already there + (when rcirc-scroll-show-maximum-output + (let ((window (get-buffer-window))) + (when window + (with-selected-window window + (when (eq major-mode 'rcirc-mode) + (when (<= (- (window-height) + (count-screen-lines (window-point) + (window-start)) + 1) + 0) + (recenter -1))))))) + + ;; flush undo (can we do something smarter here?) + (buffer-disable-undo) + (buffer-enable-undo)) + + ;; record mode line activity + (when (and activity + (not rcirc-ignore-buffer-activity-flag) + (not (and rcirc-dim-nicks sender + (string-match (regexp-opt rcirc-dim-nicks) sender) + (rcirc-channel-p target)))) + (rcirc-record-activity (current-buffer) + (when (not (rcirc-channel-p rcirc-target)) + 'nick))) + + (when (and rcirc-log-flag + (or target + rcirc-log-process-buffers)) + (rcirc-log process sender response target text)) + + (sit-for 0) ; displayed text before hook + (run-hook-with-args 'rcirc-print-functions + process sender response target text))))) + +(defun rcirc-generate-log-filename (process target) + (if target + (rcirc-generate-new-buffer-name process target) + (process-name process))) + +(defcustom rcirc-log-filename-function 'rcirc-generate-log-filename + "A function to generate the filename used by rcirc's logging facility. + +It is called with two arguments, PROCESS and TARGET (see +`rcirc-generate-new-buffer-name' for their meaning), and should +return the filename, or nil if no logging is desired for this +session. + +If the returned filename is absolute (`file-name-absolute-p' +returns t), then it is used as-is, otherwise the resulting file +is put into `rcirc-log-directory'. + +The filename is then cleaned using `convert-standard-filename' to +guarantee valid filenames for the current OS." + :group 'rcirc + :type 'function) + +(defun rcirc-log (process sender response target text) + "Record line in `rcirc-log', to be later written to disk." + (let ((filename (funcall rcirc-log-filename-function process target))) + (unless (null filename) + (let ((cell (assoc-string filename rcirc-log-alist)) + (line (concat (format-time-string rcirc-time-format) + (substring-no-properties + (rcirc-format-response-string process sender + response target text)) + "\n"))) + (if cell + (setcdr cell (concat (cdr cell) line)) + (setq rcirc-log-alist + (cons (cons filename line) rcirc-log-alist))))))) + +(defun rcirc-log-write () + "Flush `rcirc-log-alist' data to disk. + +Log data is written to `rcirc-log-directory', except for +log-files with absolute names (see `rcirc-log-filename-function')." + (dolist (cell rcirc-log-alist) + (let ((filename (convert-standard-filename + (expand-file-name (car cell) + rcirc-log-directory))) + (coding-system-for-write 'utf-8)) + (make-directory (file-name-directory filename) t) + (with-temp-buffer + (insert (cdr cell)) + (write-region (point-min) (point-max) filename t 'quiet)))) + (setq rcirc-log-alist nil)) + +(defun rcirc-view-log-file () + "View logfile corresponding to the current buffer." + (interactive) + (find-file-other-window + (expand-file-name (funcall rcirc-log-filename-function + (rcirc-buffer-process) rcirc-target) + rcirc-log-directory))) + +(defun rcirc-join-channels (process channels) + "Join CHANNELS." + (save-window-excursion + (dolist (channel channels) + (with-rcirc-process-buffer process + (rcirc-cmd-join channel process))))) + +;;; nick management +(defvar rcirc-nick-prefix-chars "~&@%+") +(defun rcirc-user-nick (user) + "Return the nick from USER. Remove any non-nick junk." + (save-match-data + (if (string-match (concat "^[" rcirc-nick-prefix-chars + "]?\\([^! ]+\\)!?") (or user "")) + (match-string 1 user) + user))) + +(defun rcirc-nick-channels (process nick) + "Return list of channels for NICK." + (with-rcirc-process-buffer process + (mapcar (lambda (x) (car x)) + (gethash nick rcirc-nick-table)))) + +(defun rcirc-put-nick-channel (process nick channel &optional line) + "Add CHANNEL to list associated with NICK. +Update the associated linestamp if LINE is non-nil. + +If the record doesn't exist, and LINE is nil, set the linestamp +to zero." + (let ((nick (rcirc-user-nick nick))) + (with-rcirc-process-buffer process + (let* ((chans (gethash nick rcirc-nick-table)) + (record (assoc-string channel chans t))) + (if record + (when line (setcdr record line)) + (puthash nick (cons (cons channel (or line 0)) + chans) + rcirc-nick-table)))))) + +(defun rcirc-nick-remove (process nick) + "Remove NICK from table." + (with-rcirc-process-buffer process + (remhash nick rcirc-nick-table))) + +(defun rcirc-remove-nick-channel (process nick channel) + "Remove the CHANNEL from list associated with NICK." + (with-rcirc-process-buffer process + (let* ((chans (gethash nick rcirc-nick-table)) + (newchans + ;; instead of assoc-string-delete-all: + (let ((record (assoc-string channel chans t))) + (when record + (setcar record 'delete) + (assq-delete-all 'delete chans))))) + (if newchans + (puthash nick newchans rcirc-nick-table) + (remhash nick rcirc-nick-table))))) + +(defun rcirc-channel-nicks (process target) + "Return the list of nicks associated with TARGET sorted by last activity." + (when target + (if (rcirc-channel-p target) + (with-rcirc-process-buffer process + (let (nicks) + (maphash + (lambda (k v) + (let ((record (assoc-string target v t))) + (if record + (setq nicks (cons (cons k (cdr record)) nicks))))) + rcirc-nick-table) + (mapcar (lambda (x) (car x)) + (sort nicks (lambda (x y) + (let ((lx (or (cdr x) 0)) + (ly (or (cdr y) 0))) + (< ly lx))))))) + (list target)))) + +(defun rcirc-ignore-update-automatic (nick) + "Remove NICK from `rcirc-ignore-list' +if NICK is also on `rcirc-ignore-list-automatic'." + (when (member nick rcirc-ignore-list-automatic) + (setq rcirc-ignore-list-automatic + (delete nick rcirc-ignore-list-automatic) + rcirc-ignore-list + (delete nick rcirc-ignore-list)))) + +(defun rcirc-nickname< (s1 s2) + "Return t if IRC nickname S1 is less than S2, and nil otherwise. +Operator nicknames (@) are considered less than voiced +nicknames (+). Any other nicknames are greater than voiced +nicknames. The comparison is case-insensitive." + (setq s1 (downcase s1) + s2 (downcase s2)) + (let* ((s1-op (eq ?@ (string-to-char s1))) + (s2-op (eq ?@ (string-to-char s2)))) + (if s1-op + (if s2-op + (string< (substring s1 1) (substring s2 1)) + t) + (if s2-op + nil + (string< s1 s2))))) + +(defun rcirc-sort-nicknames-join (input sep) + "Return a string of sorted nicknames. +INPUT is a string containing nicknames separated by SEP. +This function does not alter the INPUT string." + (let* ((parts (split-string input sep t)) + (sorted (sort parts 'rcirc-nickname<))) + (mapconcat 'identity sorted sep))) + +;;; activity tracking +(defvar rcirc-track-minor-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-@") 'rcirc-next-active-buffer) + (define-key map (kbd "C-c C-SPC") 'rcirc-next-active-buffer) + map) + "Keymap for rcirc track minor mode.") + +;;;###autoload +(define-minor-mode rcirc-track-minor-mode + "Global minor mode for tracking activity in rcirc buffers. +With a prefix argument ARG, enable the mode if ARG is positive, +and disable it otherwise. If called from Lisp, enable the mode +if ARG is omitted or nil." + :init-value nil + :lighter "" + :keymap rcirc-track-minor-mode-map + :global t + :group 'rcirc + (or global-mode-string (setq global-mode-string '(""))) + ;; toggle the mode-line channel indicator + (if rcirc-track-minor-mode + (progn + (and (not (memq 'rcirc-activity-string global-mode-string)) + (setq global-mode-string + (append global-mode-string '(rcirc-activity-string)))) + (add-hook 'window-configuration-change-hook + 'rcirc-window-configuration-change)) + (setq global-mode-string + (delete 'rcirc-activity-string global-mode-string)) + (remove-hook 'window-configuration-change-hook + 'rcirc-window-configuration-change))) + +(or (assq 'rcirc-ignore-buffer-activity-flag minor-mode-alist) + (setq minor-mode-alist + (cons '(rcirc-ignore-buffer-activity-flag " Ignore") minor-mode-alist))) +(or (assq 'rcirc-low-priority-flag minor-mode-alist) + (setq minor-mode-alist + (cons '(rcirc-low-priority-flag " LowPri") minor-mode-alist))) + +(defun rcirc-toggle-ignore-buffer-activity () + "Toggle the value of `rcirc-ignore-buffer-activity-flag'." + (interactive) + (setq rcirc-ignore-buffer-activity-flag + (not rcirc-ignore-buffer-activity-flag)) + (message (if rcirc-ignore-buffer-activity-flag + "Ignore activity in this buffer" + "Notice activity in this buffer")) + (force-mode-line-update)) + +(defun rcirc-toggle-low-priority () + "Toggle the value of `rcirc-low-priority-flag'." + (interactive) + (setq rcirc-low-priority-flag + (not rcirc-low-priority-flag)) + (message (if rcirc-low-priority-flag + "Activity in this buffer is low priority" + "Activity in this buffer is normal priority")) + (force-mode-line-update)) + +(defun rcirc-switch-to-server-buffer () + "Switch to the server buffer associated with current channel buffer." + (interactive) + (unless (buffer-live-p rcirc-server-buffer) + (error "No such buffer")) + (switch-to-buffer rcirc-server-buffer)) + +(defun rcirc-jump-to-first-unread-line () + "Move the point to the first unread line in this buffer." + (interactive) + (if (marker-position overlay-arrow-position) + (goto-char overlay-arrow-position) + (message "No unread messages"))) + +(defun rcirc-bury-buffers () + "Bury all RCIRC buffers." + (interactive) + (dolist (buf (buffer-list)) + (when (eq 'rcirc-mode (with-current-buffer buf major-mode)) + (bury-buffer buf) ; buffers not shown + (quit-windows-on buf)))) ; buffers shown in a window + +(defun rcirc-next-active-buffer (arg) + "Switch to the next rcirc buffer with activity. +With prefix ARG, go to the next low priority buffer with activity." + (interactive "P") + (let* ((pair (rcirc-split-activity rcirc-activity)) + (lopri (car pair)) + (hipri (cdr pair))) + (if (or (and (not arg) hipri) + (and arg lopri)) + (progn + (switch-to-buffer (car (if arg lopri hipri))) + (when (> (point) rcirc-prompt-start-marker) + (recenter -1))) + (rcirc-bury-buffers) + (message "No IRC activity.%s" + (if lopri + (concat + " Type C-u " (key-description (this-command-keys)) + " for low priority activity.") + ""))))) + +(define-obsolete-variable-alias 'rcirc-activity-hooks + 'rcirc-activity-functions "24.3") +(defvar rcirc-activity-functions nil + "Hook to be run when there is channel activity. + +Functions are called with a single argument, the buffer with the +activity. Only run if the buffer is not visible and +`rcirc-ignore-buffer-activity-flag' is non-nil.") + +(defun rcirc-record-activity (buffer &optional type) + "Record BUFFER activity with TYPE." + (with-current-buffer buffer + (let ((old-activity rcirc-activity) + (old-types rcirc-activity-types)) + (when (not (get-buffer-window (current-buffer) t)) + (setq rcirc-activity + (sort (if (memq (current-buffer) rcirc-activity) rcirc-activity + (cons (current-buffer) rcirc-activity)) + (lambda (b1 b2) + (let ((t1 (with-current-buffer b1 rcirc-last-post-time)) + (t2 (with-current-buffer b2 rcirc-last-post-time))) + (time-less-p t2 t1))))) + (cl-pushnew type rcirc-activity-types) + (unless (and (equal rcirc-activity old-activity) + (member type old-types)) + (rcirc-update-activity-string))))) + (run-hook-with-args 'rcirc-activity-functions buffer)) + +(defun rcirc-clear-activity (buffer) + "Clear the BUFFER activity." + (setq rcirc-activity (remove buffer rcirc-activity)) + (with-current-buffer buffer + (setq rcirc-activity-types nil))) + +(defun rcirc-clear-unread (buffer) + "Erase the last read message arrow from BUFFER." + (when (buffer-live-p buffer) + (with-current-buffer buffer + (set-marker overlay-arrow-position nil)))) + +(defun rcirc-split-activity (activity) + "Return a cons cell with ACTIVITY split into (lopri . hipri)." + (let (lopri hipri) + (dolist (buf activity) + (with-current-buffer buf + (if (and rcirc-low-priority-flag + (not (member 'nick rcirc-activity-types))) + (push buf lopri) + (push buf hipri)))) + (cons (nreverse lopri) (nreverse hipri)))) + +(defvar rcirc-update-activity-string-hook nil + "Hook run whenever the activity string is updated.") + +;; TODO: add mouse properties +(defun rcirc-update-activity-string () + "Update mode-line string." + (let* ((pair (rcirc-split-activity rcirc-activity)) + (lopri (car pair)) + (hipri (cdr pair))) + (setq rcirc-activity-string + (cond ((or hipri lopri) + (concat (and hipri "[") + (rcirc-activity-string hipri) + (and hipri lopri ",") + (and lopri + (concat "(" + (rcirc-activity-string lopri) + ")")) + (and hipri "]"))) + ((not (null (rcirc-process-list))) + "[]") + (t "[]"))) + (run-hooks 'rcirc-update-activity-string-hook))) + +(defun rcirc-activity-string (buffers) + (mapconcat (lambda (b) + (let ((s (substring-no-properties (rcirc-short-buffer-name b)))) + (with-current-buffer b + (dolist (type rcirc-activity-types) + (rcirc-add-face 0 (length s) + (cl-case type + (nick 'rcirc-track-nick) + (keyword 'rcirc-track-keyword)) + s))) + s)) + buffers ",")) + +(defun rcirc-short-buffer-name (buffer) + "Return a short name for BUFFER to use in the mode line indicator." + (with-current-buffer buffer + (or rcirc-short-buffer-name (buffer-name)))) + +(defun rcirc-visible-buffers () + "Return a list of the visible buffers that are in rcirc-mode." + (let (acc) + (walk-windows (lambda (w) + (with-current-buffer (window-buffer w) + (when (eq major-mode 'rcirc-mode) + (push (current-buffer) acc))))) + acc)) + +(defvar rcirc-visible-buffers nil) +(defun rcirc-window-configuration-change () + (unless (minibuffer-window-active-p (minibuffer-window)) + ;; delay this until command has finished to make sure window is + ;; actually visible before clearing activity + (add-hook 'post-command-hook 'rcirc-window-configuration-change-1))) + +(defun rcirc-window-configuration-change-1 () + ;; clear activity and overlay arrows + (let* ((old-activity rcirc-activity) + (hidden-buffers rcirc-visible-buffers)) + + (setq rcirc-visible-buffers (rcirc-visible-buffers)) + + (dolist (vbuf rcirc-visible-buffers) + (setq hidden-buffers (delq vbuf hidden-buffers)) + ;; clear activity for all visible buffers + (rcirc-clear-activity vbuf)) + + ;; clear unread arrow from recently hidden buffers + (dolist (hbuf hidden-buffers) + (rcirc-clear-unread hbuf)) + + ;; remove any killed buffers from list + (setq rcirc-activity + (delq nil (mapcar (lambda (buf) (when (buffer-live-p buf) buf)) + rcirc-activity))) + ;; update the mode-line string + (unless (equal old-activity rcirc-activity) + (rcirc-update-activity-string))) + + (remove-hook 'post-command-hook 'rcirc-window-configuration-change-1)) + + +;;; buffer name abbreviation +(defun rcirc-update-short-buffer-names () + (let ((bufalist + (apply 'append (mapcar (lambda (process) + (with-rcirc-process-buffer process + rcirc-buffer-alist)) + (rcirc-process-list))))) + (dolist (i (rcirc-abbreviate bufalist)) + (when (buffer-live-p (cdr i)) + (with-current-buffer (cdr i) + (setq rcirc-short-buffer-name (car i))))))) + +(defun rcirc-abbreviate (pairs) + (apply 'append (mapcar 'rcirc-rebuild-tree (rcirc-make-trees pairs)))) + +(defun rcirc-rebuild-tree (tree &optional acc) + (let ((ch (char-to-string (car tree)))) + (dolist (x (cdr tree)) + (if (listp x) + (setq acc (append acc + (mapcar (lambda (y) + (cons (concat ch (car y)) + (cdr y))) + (rcirc-rebuild-tree x)))) + (setq acc (cons (cons ch x) acc)))) + acc)) + +(defun rcirc-make-trees (pairs) + (let (alist) + (mapc (lambda (pair) + (if (consp pair) + (let* ((str (car pair)) + (data (cdr pair)) + (char (unless (zerop (length str)) + (aref str 0))) + (rest (unless (zerop (length str)) + (substring str 1))) + (part (if char (assq char alist)))) + (if part + ;; existing partition + (setcdr part (cons (cons rest data) (cdr part))) + ;; new partition + (setq alist (cons (if char + (list char (cons rest data)) + data) + alist)))) + (setq alist (cons pair alist)))) + pairs) + ;; recurse into cdrs of alist + (mapc (lambda (x) + (when (and (listp x) (listp (cadr x))) + (setcdr x (if (> (length (cdr x)) 1) + (rcirc-make-trees (cdr x)) + (setcdr x (list (cl-cdadr x))))))) + alist))) + +;;; /commands these are called with 3 args: PROCESS, TARGET, which is +;; the current buffer/channel/user, and ARGS, which is a string +;; containing the text following the /cmd. + +(defmacro defun-rcirc-command (command argument docstring interactive-form + &rest body) + "Define a command." + `(progn + (add-to-list 'rcirc-client-commands ,(concat "/" (symbol-name command))) + (defun ,(intern (concat "rcirc-cmd-" (symbol-name command))) + (,@argument &optional process target) + ,(concat docstring "\n\nNote: If PROCESS or TARGET are nil, the values given" + "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") + ,interactive-form + (let ((process (or process (rcirc-buffer-process))) + (target (or target rcirc-target))) + (ignore target) ; mark `target' variable as ignorable + ,@body)))) + +(defun-rcirc-command msg (message) + "Send private MESSAGE to TARGET." + (interactive "i") + (if (null message) + (progn + (setq target (completing-read "Message nick: " + (with-rcirc-server-buffer + rcirc-nick-table))) + (when (> (length target) 0) + (setq message (read-string (format "Message %s: " target))) + (when (> (length message) 0) + (rcirc-send-message process target message)))) + (if (not (string-match "\\([^ ]+\\) \\(.+\\)" message)) + (message "Not enough args, or something.") + (setq target (match-string 1 message) + message (match-string 2 message)) + (rcirc-send-message process target message)))) + +(defun-rcirc-command query (nick) + "Open a private chat buffer to NICK." + (interactive (list (completing-read "Query nick: " + (with-rcirc-server-buffer rcirc-nick-table)))) + (let ((existing-buffer (rcirc-get-buffer process nick))) + (switch-to-buffer (or existing-buffer + (rcirc-get-buffer-create process nick))) + (when (not existing-buffer) + (rcirc-cmd-whois nick)))) + +(defun-rcirc-command join (channels) + "Join CHANNELS. +CHANNELS is a comma- or space-separated string of channel names." + (interactive "sJoin channels: ") + (let* ((split-channels (split-string channels "[ ,]" t)) + (buffers (mapcar (lambda (ch) + (rcirc-get-buffer-create process ch)) + split-channels)) + (channels (mapconcat 'identity split-channels ","))) + (rcirc-send-string process (concat "JOIN " channels)) + (when (not (eq (selected-window) (minibuffer-window))) + (dolist (b buffers) ;; order the new channel buffers in the buffer list + (switch-to-buffer b))))) + +(defun-rcirc-command invite (nick-channel) + "Invite NICK to CHANNEL." + (interactive (list + (concat + (completing-read "Invite nick: " + (with-rcirc-server-buffer rcirc-nick-table)) + " " + (read-string "Channel: ")))) + (rcirc-send-string process (concat "INVITE " nick-channel))) + +;; TODO: /part #channel reason, or consider removing #channel altogether +(defun-rcirc-command part (channel) + "Part CHANNEL." + (interactive "sPart channel: ") + (let ((channel (if (> (length channel) 0) channel target))) + (rcirc-send-string process (concat "PART " channel " :" rcirc-id-string)))) + +(defun-rcirc-command quit (reason) + "Send a quit message to server with REASON." + (interactive "sQuit reason: ") + (rcirc-send-string process (concat "QUIT :" + (if (not (zerop (length reason))) + reason + rcirc-id-string)))) + +(defun-rcirc-command reconnect (_) + "Reconnect to current server." + (interactive "i") + (with-rcirc-server-buffer + (cond + (rcirc-connecting (message "Already connecting")) + ((process-live-p process) (message "Server process is alive")) + (t (let ((conn-info rcirc-connection-info)) + (setf (nth 5 conn-info) + (cl-remove-if-not #'rcirc-channel-p + (mapcar #'car rcirc-buffer-alist))) + (apply #'rcirc-connect conn-info)))))) + +(defun-rcirc-command nick (nick) + "Change nick to NICK." + (interactive "i") + (when (null nick) + (setq nick (read-string "New nick: " (rcirc-nick process)))) + (rcirc-send-string process (concat "NICK " nick))) + +(defun-rcirc-command names (channel) + "Display list of names in CHANNEL or in current channel if CHANNEL is nil. +If called interactively, prompt for a channel when prefix arg is supplied." + (interactive "P") + (if (called-interactively-p 'interactive) + (if channel + (setq channel (read-string "List names in channel: " target)))) + (let ((channel (if (> (length channel) 0) + channel + target))) + (rcirc-send-string process (concat "NAMES " channel)))) + +(defun-rcirc-command topic (topic) + "List TOPIC for the TARGET channel. +With a prefix arg, prompt for new topic." + (interactive "P") + (if (and (called-interactively-p 'interactive) topic) + (setq topic (read-string "New Topic: " rcirc-topic))) + (rcirc-send-string process (concat "TOPIC " target + (when (> (length topic) 0) + (concat " :" topic))))) + +(defun-rcirc-command whois (nick) + "Request information from server about NICK." + (interactive (list + (completing-read "Whois: " + (with-rcirc-server-buffer rcirc-nick-table)))) + (rcirc-send-string process (concat "WHOIS " nick))) + +(defun-rcirc-command mode (args) + "Set mode with ARGS." + (interactive (list (concat (read-string "Mode nick or channel: ") + " " (read-string "Mode: ")))) + (rcirc-send-string process (concat "MODE " args))) + +(defun-rcirc-command list (channels) + "Request information on CHANNELS from server." + (interactive "sList Channels: ") + (rcirc-send-string process (concat "LIST " channels))) + +(defun-rcirc-command oper (args) + "Send operator command to server." + (interactive "sOper args: ") + (rcirc-send-string process (concat "OPER " args))) + +(defun-rcirc-command quote (message) + "Send MESSAGE literally to server." + (interactive "sServer message: ") + (rcirc-send-string process message)) + +(defun-rcirc-command kick (arg) + "Kick NICK from current channel." + (interactive (list + (concat (completing-read "Kick nick: " + (rcirc-channel-nicks + (rcirc-buffer-process) + rcirc-target)) + (read-from-minibuffer "Kick reason: ")))) + (let* ((arglist (split-string arg)) + (argstring (concat (car arglist) " :" + (mapconcat 'identity (cdr arglist) " ")))) + (rcirc-send-string process (concat "KICK " target " " argstring)))) + +(defun rcirc-cmd-ctcp (args &optional process _target) + (if (string-match "^\\([^ ]+\\)\\s-+\\(.+\\)$" args) + (let* ((target (match-string 1 args)) + (request (upcase (match-string 2 args))) + (function (intern-soft (concat "rcirc-ctcp-sender-" request)))) + (if (fboundp function) ;; use special function if available + (funcall function process target request) + (rcirc-send-ctcp process target request))) + (rcirc-print process (rcirc-nick process) "ERROR" nil + "usage: /ctcp NICK REQUEST"))) + +(defun rcirc-ctcp-sender-PING (process target _request) + "Send a CTCP PING message to TARGET." + (let ((timestamp (format-time-string "%s"))) + (rcirc-send-ctcp process target "PING" timestamp))) + +(defun rcirc-cmd-me (args &optional process target) + (rcirc-send-ctcp process target "ACTION" args)) + +(defun rcirc-add-or-remove (set &rest elements) + (dolist (elt elements) + (if (and elt (not (string= "" elt))) + (setq set (if (member-ignore-case elt set) + (delete elt set) + (cons elt set))))) + set) + +(defun-rcirc-command ignore (nick) + "Manage the ignore list. +Ignore NICK, unignore NICK if already ignored, or list ignored +nicks when no NICK is given. When listing ignored nicks, the +ones added to the list automatically are marked with an asterisk." + (interactive "sToggle ignoring of nick: ") + (setq rcirc-ignore-list + (apply #'rcirc-add-or-remove rcirc-ignore-list + (split-string nick nil t))) + (rcirc-print process nil "IGNORE" target + (mapconcat + (lambda (nick) + (concat nick + (if (member nick rcirc-ignore-list-automatic) + "*" ""))) + rcirc-ignore-list " "))) + +(defun-rcirc-command bright (nick) + "Manage the bright nick list." + (interactive "sToggle emphasis of nick: ") + (setq rcirc-bright-nicks + (apply #'rcirc-add-or-remove rcirc-bright-nicks + (split-string nick nil t))) + (rcirc-print process nil "BRIGHT" target + (mapconcat 'identity rcirc-bright-nicks " "))) + +(defun-rcirc-command dim (nick) + "Manage the dim nick list." + (interactive "sToggle deemphasis of nick: ") + (setq rcirc-dim-nicks + (apply #'rcirc-add-or-remove rcirc-dim-nicks + (split-string nick nil t))) + (rcirc-print process nil "DIM" target + (mapconcat 'identity rcirc-dim-nicks " "))) + +(defun-rcirc-command keyword (keyword) + "Manage the keyword list. +Mark KEYWORD, unmark KEYWORD if already marked, or list marked +keywords when no KEYWORD is given." + (interactive "sToggle highlighting of keyword: ") + (setq rcirc-keywords + (apply #'rcirc-add-or-remove rcirc-keywords + (split-string keyword nil t))) + (rcirc-print process nil "KEYWORD" target + (mapconcat 'identity rcirc-keywords " "))) + + +(defun rcirc-add-face (start end name &optional object) + "Add face NAME to the face text property of the text from START to END." + (when name + (let ((pos start) + next prop) + (while (< pos end) + (setq prop (get-text-property pos 'font-lock-face object) + next (next-single-property-change pos 'font-lock-face object end)) + (unless (member name (get-text-property pos 'font-lock-face object)) + (add-text-properties pos next + (list 'font-lock-face (cons name prop)) object)) + (setq pos next))))) + +(defun rcirc-facify (string face) + "Return a copy of STRING with FACE property added." + (let ((string (or string ""))) + (rcirc-add-face 0 (length string) face string) + string)) + +(defvar rcirc-url-regexp + (concat + "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|" + "nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)" + "\\(//[-a-z0-9_.]+:[0-9]*\\)?" + (if (string-match "[[:digit:]]" "1") ;; Support POSIX? + (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]") + (punct "!?:;.,")) + (concat + "\\(?:" + ;; Match paired parentheses, e.g. in Wikipedia URLs: + "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]" + "\\|" + "[" chars punct "]+" "[" chars "]" + "\\)")) + (concat ;; XEmacs 21.4 doesn't support POSIX. + "\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+" + "\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)")) + "\\)") + "Regexp matching URLs. Set to nil to disable URL features in rcirc.") + +;; cf cl-remove-if-not +(defun rcirc-condition-filter (condp lst) + "Remove all items not satisfying condition CONDP in list LST. +CONDP is a function that takes a list element as argument and returns +non-nil if that element should be included. Returns a new list." + (delq nil (mapcar (lambda (x) (and (funcall condp x) x)) lst))) + +(defun rcirc-browse-url (&optional arg) + "Prompt for URL to browse based on URLs in buffer before point. + +If ARG is given, opens the URL in a new browser window." + (interactive "P") + (let* ((point (point)) + (filtered (rcirc-condition-filter + (lambda (x) (>= point (cdr x))) + rcirc-urls)) + (completions (mapcar (lambda (x) (car x)) filtered)) + (defaults (mapcar (lambda (x) (car x)) filtered))) + (browse-url (completing-read "Rcirc browse-url: " + completions nil nil (car defaults) nil defaults) + arg))) + +(defun rcirc-markup-timestamp (_sender _response) + (goto-char (point-min)) + (insert (rcirc-facify (format-time-string rcirc-time-format + (let ((time rcirc-last-message-time)) + (when time (setq rcirc-last-message-time nil)) + time)) + 'rcirc-timestamp))) + +(defun rcirc-markup-attributes (_sender _response) + (while (re-search-forward "\\([\C-b\C-_\C-v]\\).*?\\(\\1\\|\C-o\\)" nil t) + (rcirc-add-face (match-beginning 0) (match-end 0) + (cl-case (char-after (match-beginning 1)) + (?\C-b 'bold) + (?\C-v 'italic) + (?\C-_ 'underline))) + ;; keep the ^O since it could terminate other attributes + (when (not (eq ?\C-o (char-before (match-end 2)))) + (delete-region (match-beginning 2) (match-end 2))) + (delete-region (match-beginning 1) (match-end 1)) + (goto-char (match-beginning 1))) + ;; remove the ^O characters now + (goto-char (point-min)) + (while (re-search-forward "\C-o+" nil t) + (delete-region (match-beginning 0) (match-end 0)))) + +(defun rcirc-markup-my-nick (_sender response) + (with-syntax-table rcirc-nick-syntax-table + (while (re-search-forward (concat "\\b" + (regexp-quote (rcirc-nick + (rcirc-buffer-process))) + "\\b") + nil t) + (rcirc-add-face (match-beginning 0) (match-end 0) + 'rcirc-nick-in-message) + (when (string= response "PRIVMSG") + (rcirc-add-face (point-min) (point-max) + 'rcirc-nick-in-message-full-line) + (rcirc-record-activity (current-buffer) 'nick))))) + +(defun rcirc-markup-urls (_sender _response) + (while (and rcirc-url-regexp ;; nil means disable URL catching + (re-search-forward rcirc-url-regexp nil t)) + (let* ((start (match-beginning 0)) + (end (match-end 0)) + (url (match-string-no-properties 0)) + (link-text (buffer-substring-no-properties start end))) + ;; Add a button for the URL. Note that we use `make-text-button', + ;; rather than `make-button', as text-buttons are much faster in + ;; large buffers. + (make-text-button start end + 'face 'rcirc-url + 'follow-link t + 'rcirc-url url + 'action (lambda (button) + (browse-url (button-get button 'rcirc-url)))) + ;; record the url if it is not already the latest stored url + (when (not (string= link-text (caar rcirc-urls))) + (push (cons link-text start) rcirc-urls))))) + +(defun rcirc-markup-keywords (sender response) + (when (and (string= response "PRIVMSG") + (not (string= sender (rcirc-nick (rcirc-buffer-process))))) + (let* ((target (or rcirc-target "")) + (keywords (delq nil (mapcar (lambda (keyword) + (when (not (string-match keyword + target)) + keyword)) + rcirc-keywords)))) + (when keywords + (while (re-search-forward (regexp-opt keywords 'words) nil t) + (rcirc-add-face (match-beginning 0) (match-end 0) 'rcirc-keyword) + (rcirc-record-activity (current-buffer) 'keyword)))))) + +(defun rcirc-markup-bright-nicks (_sender response) + (when (and rcirc-bright-nicks + (string= response "NAMES")) + (with-syntax-table rcirc-nick-syntax-table + (while (re-search-forward (regexp-opt rcirc-bright-nicks 'words) nil t) + (rcirc-add-face (match-beginning 0) (match-end 0) + 'rcirc-bright-nick))))) + +(defun rcirc-markup-fill (_sender response) + (when (not (string= response "372")) ; /motd + (let ((fill-prefix + (or rcirc-fill-prefix + (make-string (- (point) (line-beginning-position)) ?\s))) + (fill-column (- (cond ((null rcirc-fill-column) fill-column) + ((functionp rcirc-fill-column) + (funcall rcirc-fill-column)) + (t rcirc-fill-column)) + ;; make sure ... doesn't cause line wrapping + 3))) + (fill-region (point) (point-max) nil t)))) + +;;; handlers +;; these are called with the server PROCESS, the SENDER, which is a +;; server or a user, depending on the command, the ARGS, which is a +;; list of strings, and the TEXT, which is the original server text, +;; verbatim +(defun rcirc-handler-001 (process sender args text) + (rcirc-handler-generic process "001" sender args text) + (with-rcirc-process-buffer process + (setq rcirc-connecting nil) + (rcirc-reschedule-timeout process) + (setq rcirc-server-name sender) + (setq rcirc-nick (car args)) + (rcirc-update-prompt) + (if rcirc-auto-authenticate-flag + (if (and rcirc-authenticate-before-join + ;; We have to ensure that there's an authentication + ;; entry for that server. Else, + ;; rcirc-authenticated-hook won't be triggered, and + ;; autojoin won't happen at all. + (let (auth-required) + (dolist (s rcirc-authinfo auth-required) + (when (string-match (car s) rcirc-server-name) + (setq auth-required t))))) + (progn + (add-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t t) + (rcirc-authenticate)) + (rcirc-authenticate) + (rcirc-join-channels process rcirc-startup-channels)) + (rcirc-join-channels process rcirc-startup-channels)))) + +(defun rcirc-join-channels-post-auth (process) + "Join `rcirc-startup-channels' after authenticating." + (with-rcirc-process-buffer process + (rcirc-join-channels process rcirc-startup-channels))) + +(defun rcirc-handler-PRIVMSG (process sender args text) + (rcirc-check-auth-status process sender args text) + (let ((target (if (rcirc-channel-p (car args)) + (car args) + sender)) + (message (or (cadr args) ""))) + (if (string-match "^\C-a\\(.*\\)\C-a$" message) + (rcirc-handler-CTCP process target sender (match-string 1 message)) + (rcirc-print process sender "PRIVMSG" target message t)) + ;; update nick linestamp + (with-current-buffer (rcirc-get-buffer process target t) + (rcirc-put-nick-channel process sender target rcirc-current-line)))) + +(defun rcirc-handler-NOTICE (process sender args text) + (rcirc-check-auth-status process sender args text) + (let ((target (car args)) + (message (cadr args))) + (if (string-match "^\C-a\\(.*\\)\C-a$" message) + (rcirc-handler-CTCP-response process target sender + (match-string 1 message)) + (rcirc-print process sender "NOTICE" + (cond ((rcirc-channel-p target) + target) + ;;; -ChanServ- [#gnu] Welcome... + ((string-match "\\[\\(#[^] ]+\\)\\]" message) + (match-string 1 message)) + (sender + (if (string= sender (rcirc-server-name process)) + nil ; server notice + sender))) + message t)))) + +(defun rcirc-check-auth-status (process sender args _text) + "Check if the user just authenticated. +If authenticated, runs `rcirc-authenticated-hook' with PROCESS as +the only argument." + (with-rcirc-process-buffer process + (when (and (not rcirc-user-authenticated) + rcirc-authenticate-before-join + rcirc-auto-authenticate-flag) + (let ((target (car args)) + (message (cadr args))) + (when (or + (and ;; nickserv + (string= sender "NickServ") + (string= target rcirc-nick) + (member message + (list + (format "You are now identified for \C-b%s\C-b." rcirc-nick) + (format "You are successfully identified as \C-b%s\C-b." rcirc-nick) + "Password accepted - you are now recognized." + ))) + (and ;; quakenet + (string= sender "Q") + (string= target rcirc-nick) + (string-match "\\`You are now logged in as .+\\.\\'" message))) + (setq rcirc-user-authenticated t) + (run-hook-with-args 'rcirc-authenticated-hook process) + (remove-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t)))))) + +(defun rcirc-handler-WALLOPS (process sender args _text) + (rcirc-print process sender "WALLOPS" sender (car args) t)) + +(defun rcirc-handler-JOIN (process sender args _text) + (let ((channel (car args))) + (with-current-buffer (rcirc-get-buffer-create process channel) + ;; when recently rejoining, restore the linestamp + (rcirc-put-nick-channel process sender channel + (let ((last-activity-lines + (rcirc-elapsed-lines process sender channel))) + (when (and last-activity-lines + (< last-activity-lines rcirc-omit-threshold)) + (rcirc-last-line process sender channel)))) + ;; reset mode-line-process in case joining a channel with an + ;; already open buffer (after getting kicked e.g.) + (setq mode-line-process nil)) + + (rcirc-print process sender "JOIN" channel "") + + ;; print in private chat buffer if it exists + (when (rcirc-get-buffer (rcirc-buffer-process) sender) + (rcirc-print process sender "JOIN" sender channel)))) + +;; PART and KICK are handled the same way +(defun rcirc-handler-PART-or-KICK (process _response channel _sender nick _args) + (rcirc-ignore-update-automatic nick) + (if (not (string= nick (rcirc-nick process))) + ;; this is someone else leaving + (progn + (rcirc-maybe-remember-nick-quit process nick channel) + (rcirc-remove-nick-channel process nick channel)) + ;; this is us leaving + (mapc (lambda (n) + (rcirc-remove-nick-channel process n channel)) + (rcirc-channel-nicks process channel)) + + ;; if the buffer is still around, make it inactive + (let ((buffer (rcirc-get-buffer process channel))) + (when buffer + (rcirc-disconnect-buffer buffer))))) + +(defun rcirc-handler-PART (process sender args _text) + (let* ((channel (car args)) + (reason (cadr args)) + (message (concat channel " " reason))) + (rcirc-print process sender "PART" channel message) + ;; print in private chat buffer if it exists + (when (rcirc-get-buffer (rcirc-buffer-process) sender) + (rcirc-print process sender "PART" sender message)) + + (rcirc-handler-PART-or-KICK process "PART" channel sender sender reason))) + +(defun rcirc-handler-KICK (process sender args _text) + (let* ((channel (car args)) + (nick (cadr args)) + (reason (nth 2 args)) + (message (concat nick " " channel " " reason))) + (rcirc-print process sender "KICK" channel message t) + ;; print in private chat buffer if it exists + (when (rcirc-get-buffer (rcirc-buffer-process) nick) + (rcirc-print process sender "KICK" nick message)) + + (rcirc-handler-PART-or-KICK process "KICK" channel sender nick reason))) + +(defun rcirc-maybe-remember-nick-quit (process nick channel) + "Remember NICK as leaving CHANNEL if they recently spoke." + (let ((elapsed-lines (rcirc-elapsed-lines process nick channel))) + (when (and elapsed-lines + (< elapsed-lines rcirc-omit-threshold)) + (let ((buffer (rcirc-get-buffer process channel))) + (when buffer + (with-current-buffer buffer + (let ((record (assoc-string nick rcirc-recent-quit-alist t)) + (line (rcirc-last-line process nick channel))) + (if record + (setcdr record line) + (setq rcirc-recent-quit-alist + (cons (cons nick line) + rcirc-recent-quit-alist)))))))))) + +(defun rcirc-handler-QUIT (process sender args _text) + (rcirc-ignore-update-automatic sender) + (mapc (lambda (channel) + ;; broadcast quit message each channel + (rcirc-print process sender "QUIT" channel (apply 'concat args)) + ;; record nick in quit table if they recently spoke + (rcirc-maybe-remember-nick-quit process sender channel)) + (rcirc-nick-channels process sender)) + (rcirc-nick-remove process sender)) + +(defun rcirc-handler-NICK (process sender args _text) + (let* ((old-nick sender) + (new-nick (car args)) + (channels (rcirc-nick-channels process old-nick))) + ;; update list of ignored nicks + (rcirc-ignore-update-automatic old-nick) + (when (member old-nick rcirc-ignore-list) + (add-to-list 'rcirc-ignore-list new-nick) + (add-to-list 'rcirc-ignore-list-automatic new-nick)) + ;; print message to nick's channels + (dolist (target channels) + (rcirc-print process sender "NICK" target new-nick)) + ;; update private chat buffer, if it exists + (let ((chat-buffer (rcirc-get-buffer process old-nick))) + (when chat-buffer + (with-current-buffer chat-buffer + (rcirc-print process sender "NICK" old-nick new-nick) + (setq rcirc-target new-nick) + (rename-buffer (rcirc-generate-new-buffer-name process new-nick))))) + ;; remove old nick and add new one + (with-rcirc-process-buffer process + (let ((v (gethash old-nick rcirc-nick-table))) + (remhash old-nick rcirc-nick-table) + (puthash new-nick v rcirc-nick-table)) + ;; if this is our nick... + (when (string= old-nick rcirc-nick) + (setq rcirc-nick new-nick) + (rcirc-update-prompt t) + ;; reauthenticate + (when rcirc-auto-authenticate-flag (rcirc-authenticate)))))) + +(defun rcirc-handler-PING (process _sender args _text) + (rcirc-send-string process (concat "PONG :" (car args)))) + +(defun rcirc-handler-PONG (_process _sender _args _text) + ;; do nothing + ) + +(defun rcirc-handler-TOPIC (process sender args _text) + (let ((topic (cadr args))) + (rcirc-print process sender "TOPIC" (car args) topic) + (with-current-buffer (rcirc-get-buffer process (car args)) + (setq rcirc-topic topic)))) + +(defvar rcirc-nick-away-alist nil) +(defun rcirc-handler-301 (process _sender args text) + "RPL_AWAY" + (let* ((nick (cadr args)) + (rec (assoc-string nick rcirc-nick-away-alist)) + (away-message (nth 2 args))) + (when (or (not rec) + (not (string= (cdr rec) away-message))) + ;; away message has changed + (rcirc-handler-generic process "AWAY" nick (cdr args) text) + (if rec + (setcdr rec away-message) + (setq rcirc-nick-away-alist (cons (cons nick away-message) + rcirc-nick-away-alist)))))) + +(defun rcirc-handler-317 (process sender args _text) + "RPL_WHOISIDLE" + (let* ((nick (nth 1 args)) + (idle-secs (string-to-number (nth 2 args))) + (idle-string + (if (< idle-secs most-positive-fixnum) + (format-seconds "%yy %dd %hh %mm %z%ss" idle-secs) + "a very long time")) + (signon-time (seconds-to-time (string-to-number (nth 3 args)))) + (signon-string (format-time-string "%c" signon-time)) + (message (format "%s idle for %s, signed on %s" + nick idle-string signon-string))) + (rcirc-print process sender "317" nil message t))) + +(defun rcirc-handler-332 (process _sender args _text) + "RPL_TOPIC" + (let ((buffer (or (rcirc-get-buffer process (cadr args)) + (rcirc-get-temp-buffer-create process (cadr args))))) + (with-current-buffer buffer + (setq rcirc-topic (nth 2 args))))) + +(defun rcirc-handler-333 (process sender args _text) + "333 says who set the topic and when. +Not in rfc1459.txt" + (let ((buffer (or (rcirc-get-buffer process (cadr args)) + (rcirc-get-temp-buffer-create process (cadr args))))) + (with-current-buffer buffer + (let ((setter (nth 2 args)) + (time (current-time-string + (seconds-to-time + (string-to-number (cl-cadddr args)))))) + (rcirc-print process sender "TOPIC" (cadr args) + (format "%s (%s on %s)" rcirc-topic setter time)))))) + +(defun rcirc-handler-477 (process sender args _text) + "ERR_NOCHANMODES" + (rcirc-print process sender "477" (cadr args) (nth 2 args))) + +(defun rcirc-handler-MODE (process sender args _text) + (let ((target (car args)) + (msg (mapconcat 'identity (cdr args) " "))) + (rcirc-print process sender "MODE" + (if (string= target (rcirc-nick process)) + nil + target) + msg) + + ;; print in private chat buffers if they exist + (mapc (lambda (nick) + (when (rcirc-get-buffer process nick) + (rcirc-print process sender "MODE" nick msg))) + (cddr args)))) + +(defun rcirc-get-temp-buffer-create (process channel) + "Return a buffer based on PROCESS and CHANNEL." + (let ((tmpnam (concat " " (downcase channel) "TMP" (process-name process)))) + (get-buffer-create tmpnam))) + +(defun rcirc-handler-353 (process _sender args _text) + "RPL_NAMREPLY" + (let ((channel (nth 2 args)) + (names (or (nth 3 args) ""))) + (mapc (lambda (nick) + (rcirc-put-nick-channel process nick channel)) + (split-string names " " t)) + ;; create a temporary buffer to insert the names into + ;; rcirc-handler-366 (RPL_ENDOFNAMES) will handle it + (with-current-buffer (rcirc-get-temp-buffer-create process channel) + (goto-char (point-max)) + (insert (car (last args)) " ")))) + +(defun rcirc-handler-366 (process sender args _text) + "RPL_ENDOFNAMES" + (let* ((channel (cadr args)) + (buffer (rcirc-get-temp-buffer-create process channel))) + (with-current-buffer buffer + (rcirc-print process sender "NAMES" channel + (let ((content (buffer-substring (point-min) (point-max)))) + (rcirc-sort-nicknames-join content " ")))) + (kill-buffer buffer))) + +(defun rcirc-handler-433 (process sender args text) + "ERR_NICKNAMEINUSE" + (rcirc-handler-generic process "433" sender args text) + (let* ((new-nick (concat (cadr args) "`"))) + (with-rcirc-process-buffer process + (rcirc-cmd-nick new-nick nil process)))) + +(defun rcirc-authenticate () + "Send authentication to process associated with current buffer. +Passwords are stored in `rcirc-authinfo' (which see)." + (interactive) + (with-rcirc-server-buffer + (dolist (i rcirc-authinfo) + (let ((process (rcirc-buffer-process)) + (server (car i)) + (nick (nth 2 i)) + (method (cadr i)) + (args (cl-cdddr i))) + (when (and (string-match server rcirc-server)) + (if (and (memq method '(nickserv chanserv bitlbee)) + (string-match nick rcirc-nick)) + ;; the following methods rely on the user's nickname. + (cl-case method + (nickserv + (rcirc-send-privmsg + process + (or (cadr args) "NickServ") + (concat "IDENTIFY " (car args)))) + (chanserv + (rcirc-send-privmsg + process + "ChanServ" + (format "IDENTIFY %s %s" (car args) (cadr args)))) + (bitlbee + (rcirc-send-privmsg + process + "&bitlbee" + (concat "IDENTIFY " (car args))))) + ;; quakenet authentication doesn't rely on the user's nickname. + ;; the variable `nick' here represents the Q account name. + (when (eq method 'quakenet) + (rcirc-send-privmsg + process + "Q@CServe.quakenet.org" + (format "AUTH %s %s" nick (car args)))))))))) + +(defun rcirc-handler-INVITE (process sender args _text) + (rcirc-print process sender "INVITE" nil (mapconcat 'identity args " ") t)) + +(defun rcirc-handler-ERROR (process sender args _text) + (rcirc-print process sender "ERROR" nil (mapconcat 'identity args " "))) + +(defun rcirc-handler-CTCP (process target sender text) + (if (string-match "^\\([^ ]+\\) *\\(.*\\)$" text) + (let* ((request (upcase (match-string 1 text))) + (args (match-string 2 text)) + (handler (intern-soft (concat "rcirc-handler-ctcp-" request)))) + (if (not (fboundp handler)) + (rcirc-print process sender "ERROR" target + (format "%s sent unsupported ctcp: %s" sender text) + t) + (funcall handler process target sender args) + (unless (or (string= request "ACTION") + (string= request "KEEPALIVE")) + (rcirc-print process sender "CTCP" target + (format "%s" text) t)))))) + +(defun rcirc-handler-ctcp-VERSION (process _target sender _args) + (rcirc-send-string process + (concat "NOTICE " sender + " :\C-aVERSION " rcirc-id-string + "\C-a"))) + +(defun rcirc-handler-ctcp-ACTION (process target sender args) + (rcirc-print process sender "ACTION" target args t)) + +(defun rcirc-handler-ctcp-TIME (process _target sender _args) + (rcirc-send-string process + (concat "NOTICE " sender + " :\C-aTIME " (current-time-string) "\C-a"))) + +(defun rcirc-handler-CTCP-response (process _target sender message) + (rcirc-print process sender "CTCP" nil message t)) + +(defun rcirc-handler-CAP (process _sender args _text) + (when (equal (cadr args) "LS") + (rcirc-send-string process "CAP REQ :server-time")) + + (when (or (equal (cadr args) "ACK") + (equal (cadr args) "NAK")) + ;; Capability negotiation is best-effort here, I know that my + ;; servers support server-time and thus we end negotiation + ;; immediately. + (rcirc-send-string process "CAP END"))) + +(defgroup rcirc-faces nil + "Faces for rcirc." + :group 'rcirc + :group 'faces) + +(defface rcirc-my-nick ; font-lock-function-name-face + '((((class color) (min-colors 88) (background light)) :foreground "Blue1") + (((class color) (min-colors 88) (background dark)) :foreground "LightSkyBlue") + (((class color) (min-colors 16) (background light)) :foreground "Blue") + (((class color) (min-colors 16) (background dark)) :foreground "LightSkyBlue") + (((class color) (min-colors 8)) :foreground "blue" :weight bold) + (t :inverse-video t :weight bold)) + "Rcirc face for my messages." + :group 'rcirc-faces) + +(defface rcirc-other-nick ; font-lock-variable-name-face + '((((class grayscale) (background light)) + :foreground "Gray90" :weight bold :slant italic) + (((class grayscale) (background dark)) + :foreground "DimGray" :weight bold :slant italic) + (((class color) (min-colors 88) (background light)) :foreground "DarkGoldenrod") + (((class color) (min-colors 88) (background dark)) :foreground "LightGoldenrod") + (((class color) (min-colors 16) (background light)) :foreground "DarkGoldenrod") + (((class color) (min-colors 16) (background dark)) :foreground "LightGoldenrod") + (((class color) (min-colors 8)) :foreground "yellow" :weight light) + (t :weight bold :slant italic)) + "Rcirc face for other users' messages." + :group 'rcirc-faces) + +(defface rcirc-bright-nick + '((((class grayscale) (background light)) + :foreground "LightGray" :weight bold :underline t) + (((class grayscale) (background dark)) + :foreground "Gray50" :weight bold :underline t) + (((class color) (min-colors 88) (background light)) :foreground "CadetBlue") + (((class color) (min-colors 88) (background dark)) :foreground "Aquamarine") + (((class color) (min-colors 16) (background light)) :foreground "CadetBlue") + (((class color) (min-colors 16) (background dark)) :foreground "Aquamarine") + (((class color) (min-colors 8)) :foreground "magenta") + (t :weight bold :underline t)) + "Rcirc face for nicks matched by `rcirc-bright-nicks'." + :group 'rcirc-faces) + +(defface rcirc-dim-nick + '((t :inherit default)) + "Rcirc face for nicks in `rcirc-dim-nicks'." + :group 'rcirc-faces) + +(defface rcirc-server ; font-lock-comment-face + '((((class grayscale) (background light)) + :foreground "DimGray" :weight bold :slant italic) + (((class grayscale) (background dark)) + :foreground "LightGray" :weight bold :slant italic) + (((class color) (min-colors 88) (background light)) + :foreground "Firebrick") + (((class color) (min-colors 88) (background dark)) + :foreground "chocolate1") + (((class color) (min-colors 16) (background light)) + :foreground "red") + (((class color) (min-colors 16) (background dark)) + :foreground "red1") + (((class color) (min-colors 8) (background light))) + (((class color) (min-colors 8) (background dark))) + (t :weight bold :slant italic)) + "Rcirc face for server messages." + :group 'rcirc-faces) + +(defface rcirc-server-prefix ; font-lock-comment-delimiter-face + '((default :inherit rcirc-server) + (((class grayscale))) + (((class color) (min-colors 16))) + (((class color) (min-colors 8) (background light)) + :foreground "red") + (((class color) (min-colors 8) (background dark)) + :foreground "red1")) + "Rcirc face for server prefixes." + :group 'rcirc-faces) + +(defface rcirc-timestamp + '((t :inherit default)) + "Rcirc face for timestamps." + :group 'rcirc-faces) + +(defface rcirc-nick-in-message ; font-lock-keyword-face + '((((class grayscale) (background light)) :foreground "LightGray" :weight bold) + (((class grayscale) (background dark)) :foreground "DimGray" :weight bold) + (((class color) (min-colors 88) (background light)) :foreground "Purple") + (((class color) (min-colors 88) (background dark)) :foreground "Cyan1") + (((class color) (min-colors 16) (background light)) :foreground "Purple") + (((class color) (min-colors 16) (background dark)) :foreground "Cyan") + (((class color) (min-colors 8)) :foreground "cyan" :weight bold) + (t :weight bold)) + "Rcirc face for instances of your nick within messages." + :group 'rcirc-faces) + +(defface rcirc-nick-in-message-full-line '((t :weight bold)) + "Rcirc face for emphasizing the entire message when your nick is mentioned." + :group 'rcirc-faces) + +(defface rcirc-prompt ; comint-highlight-prompt + '((((min-colors 88) (background dark)) :foreground "cyan1") + (((background dark)) :foreground "cyan") + (t :foreground "dark blue")) + "Rcirc face for prompts." + :group 'rcirc-faces) + +(defface rcirc-track-nick + '((((type tty)) :inherit default) + (t :inverse-video t)) + "Rcirc face used in the mode-line when your nick is mentioned." + :group 'rcirc-faces) + +(defface rcirc-track-keyword '((t :weight bold)) + "Rcirc face used in the mode-line when keywords are mentioned." + :group 'rcirc-faces) + +(defface rcirc-url '((t :weight bold)) + "Rcirc face used to highlight urls." + :group 'rcirc-faces) + +(defface rcirc-keyword '((t :inherit highlight)) + "Rcirc face used to highlight keywords." + :group 'rcirc-faces) + + +;; When using M-x flyspell-mode, only check words after the prompt +(put 'rcirc-mode 'flyspell-mode-predicate 'rcirc-looking-at-input) +(defun rcirc-looking-at-input () + "Returns true if point is past the input marker." + (>= (point) rcirc-prompt-end-marker)) + + +(provide 'rcirc) + +;;; rcirc.el ends here diff --git a/third_party/exwm/.elpaignore b/third_party/exwm/.elpaignore new file mode 100644 index 0000000000..f0f644ee08 --- /dev/null +++ b/third_party/exwm/.elpaignore @@ -0,0 +1,2 @@ +LICENSE +README.md diff --git a/third_party/exwm/.gitignore b/third_party/exwm/.gitignore new file mode 100644 index 0000000000..9e4b0ee5b4 --- /dev/null +++ b/third_party/exwm/.gitignore @@ -0,0 +1,3 @@ +*.elc +*-pkg.el +*-autoloads.el diff --git a/third_party/exwm/LICENSE b/third_party/exwm/LICENSE new file mode 100644 index 0000000000..9cecc1d466 --- /dev/null +++ b/third_party/exwm/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/> + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + {one line to give the program's name and a brief idea of what it does.} + Copyright (C) {year} {name of author} + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see <http://www.gnu.org/licenses/>. + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + {project} Copyright (C) {year} {fullname} + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +<http://www.gnu.org/licenses/>. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +<http://www.gnu.org/philosophy/why-not-lgpl.html>. diff --git a/third_party/exwm/README.md b/third_party/exwm/README.md new file mode 100644 index 0000000000..6d7e0dd1ff --- /dev/null +++ b/third_party/exwm/README.md @@ -0,0 +1,21 @@ +# Emacs X Window Manager + +EXWM (Emacs X Window Manager) is a full-featured tiling X window manager +for Emacs built on top of [XELB](https://github.com/ch11ng/xelb). +It features: ++ Fully keyboard-driven operations ++ Hybrid layout modes (tiling & stacking) ++ Dynamic workspace support ++ ICCCM/EWMH compliance ++ (Optional) RandR (multi-monitor) support ++ (Optional) Builtin system tray ++ (Optional) Builtin input method + +Please check out the +[screenshots](https://github.com/ch11ng/exwm/wiki/Screenshots) +to get an overview of what EXWM is capable of, +and the [user guide](https://github.com/ch11ng/exwm/wiki) +for a detailed explanation of its usage. + +**Note**: If you install EXWM from source, it's recommended to install +XELB also from source (otherwise install both from GNU ELPA). diff --git a/third_party/exwm/default.nix b/third_party/exwm/default.nix new file mode 100644 index 0000000000..6daee882fe --- /dev/null +++ b/third_party/exwm/default.nix @@ -0,0 +1,14 @@ +{ depot, pkgs, lib, ... }: + +# special dance for overriding this into the fixed-point of emacs +# packages, but having it be separately buildable. + +pkgs.emacsPackages.callPackage + ({ trivialBuild, xelb }: trivialBuild { + pname = "depot-exwm"; + version = "canon"; + src = ./.; + + packageRequires = [ xelb ]; + }) +{ } diff --git a/third_party/exwm/exwm-background.el b/third_party/exwm/exwm-background.el new file mode 100644 index 0000000000..fa663d8fe6 --- /dev/null +++ b/third_party/exwm/exwm-background.el @@ -0,0 +1,199 @@ +;;; exwm-background.el --- X Background Module for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 2022-2024 Free Software Foundation, Inc. + +;; Author: Steven Allen <steven@stebalien.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module adds X background color setting support to EXWM. + +;; To use this module, load and enable it as follows: +;; (require 'exwm-background) +;; (exwm-background-enable) +;; +;; By default, this will apply the theme's background color. However, that +;; color can be customized via the `exwm-background-color' setting. + +;;; Code: + +(require 'exwm-core) + +(defcustom exwm-background-color nil + "Background color for Xorg." + :type '(choice + (color :tag "Background Color") + (const :tag "Default" nil)) + :group 'exwm + :initialize #'custom-initialize-default + :set (lambda (symbol value) + (set-default-toplevel-value symbol value) + (exwm-background--update))) + +(defconst exwm-background--properties '("_XROOTPMAP_ID" "_XSETROOT_ID" "ESETROOT_PMAP_ID") + "The background properties to set. +We can't need to set these so that compositing window managers +can correctly display the background color.") + +(defvar exwm-background--connection nil + "The X connection used for setting the background. +We use a separate connection as other background-setting tools +may kill this connection when they replace it.") + +(defvar exwm-background--pixmap nil + "Cached background pixmap.") + +(defvar exwm-background--atoms nil + "Cached background atoms.") + +(defun exwm-background--update (&rest _) + "Update the EXWM background." + + ;; Always reconnect as any tool that sets the background may have disconnected us (to force X to + ;; free resources). + (exwm-background--connect) + + (let ((gc (xcb:generate-id exwm-background--connection)) + (color (exwm--color->pixel (or exwm-background-color + (face-background 'default))))) + ;; Fill the pixmap. + (xcb:+request exwm-background--connection + (make-instance 'xcb:CreateGC + :cid gc :drawable exwm-background--pixmap + :value-mask (logior xcb:GC:Foreground + xcb:GC:GraphicsExposures) + :foreground color + :graphics-exposures 0)) + + (xcb:+request exwm-background--connection + (make-instance 'xcb:PolyFillRectangle + :gc gc :drawable exwm-background--pixmap + :rectangles + (list + (make-instance + 'xcb:RECTANGLE + :x 0 :y 0 :width 1 :height 1)))) + (xcb:+request exwm-background--connection (make-instance 'xcb:FreeGC :gc gc))) + + ;; Reapply it to force an update (also clobber anyone else who may have set it). + (xcb:+request exwm-background--connection + (make-instance 'xcb:ChangeWindowAttributes + :window exwm--root + :value-mask xcb:CW:BackPixmap + :background-pixmap exwm-background--pixmap)) + + (let (old) + ;; Collect old pixmaps so we can kill other background clients (all the background setting tools + ;; seem to do this). + (dolist (atom exwm-background--atoms) + (when-let* ((reply (xcb:+request-unchecked+reply exwm-background--connection + (make-instance 'xcb:GetProperty + :delete 0 + :window exwm--root + :property atom + :type xcb:Atom:PIXMAP + :long-offset 0 + :long-length 1))) + (value (vconcat (slot-value reply 'value))) + ((length= value 4)) + (pixmap (funcall (if xcb:lsb #'xcb:-unpack-u4-lsb #'xcb:-unpack-u4) + value 0)) + ((not (or (= pixmap exwm-background--pixmap) + (member pixmap old))))) + (push pixmap old))) + + ;; Change the background. + (dolist (atom exwm-background--atoms) + (xcb:+request exwm-background--connection + (make-instance 'xcb:ChangeProperty + :window exwm--root + :property atom + :type xcb:Atom:PIXMAP + :format 32 + :mode xcb:PropMode:Replace + :data-len 1 + :data + (funcall (if xcb:lsb + #'xcb:-pack-u4-lsb + #'xcb:-pack-u4) + exwm-background--pixmap)))) + + ;; Kill the old background clients. + (dolist (pixmap old) + (xcb:+request exwm-background--connection + (make-instance 'xcb:KillClient :resource pixmap)))) + + (xcb:flush exwm-background--connection)) + +(defun exwm-background--connected-p () + (and exwm-background--connection + (process-live-p (slot-value exwm-background--connection 'process)))) + +(defun exwm-background--connect () + (unless (exwm-background--connected-p) + (setq exwm-background--connection (xcb:connect)) + ;;prevent query message on exit + (set-process-query-on-exit-flag (slot-value exwm-background--connection 'process) nil) + + ;; Intern the background property atoms. + (setq exwm-background--atoms + (mapcar + (lambda (prop) (exwm--intern-atom prop exwm-background--connection)) + exwm-background--properties)) + + ;; Create the pixmap. + (setq exwm-background--pixmap (xcb:generate-id exwm-background--connection)) + (xcb:+request exwm-background--connection + (make-instance 'xcb:CreatePixmap + :depth + (slot-value + (xcb:+request-unchecked+reply exwm-background--connection + (make-instance 'xcb:GetGeometry :drawable exwm--root)) + 'depth) + :pid exwm-background--pixmap + :drawable exwm--root + :width 1 :height 1)))) + +(defun exwm-background--init () + "Initialize background module." + (exwm--log) + (add-hook 'enable-theme-functions 'exwm-background--update) + (add-hook 'disable-theme-functions 'exwm-background--update) + (exwm-background--update)) + +(defun exwm-background--exit () + "Uninitialize the background module." + (exwm--log) + (remove-hook 'enable-theme-functions 'exwm-background--update) + (remove-hook 'disable-theme-functions 'exwm-background--update) + (when (and exwm-background--connection + (slot-value exwm-background--connection 'connected)) + (xcb:disconnect exwm-background--connection)) + (setq exwm-background--pixmap nil + exwm-background--connection nil + exwm-background--atoms nil)) + +(defun exwm-background-enable () + "Enable background support for EXWM." + (exwm--log) + (add-hook 'exwm-init-hook #'exwm-background--init) + (add-hook 'exwm-exit-hook #'exwm-background--exit)) + +(provide 'exwm-background) + +;;; exwm-background.el ends here diff --git a/third_party/exwm/exwm-config.el b/third_party/exwm/exwm-config.el new file mode 100644 index 0000000000..a9f21e9c8c --- /dev/null +++ b/third_party/exwm/exwm-config.el @@ -0,0 +1,131 @@ +;;; exwm-config.el --- Predefined configurations -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2024 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module contains typical (yet minimal) configurations of EXWM. + +;;; Code: + +(require 'exwm) +(require 'ido) + +(define-obsolete-function-alias 'exwm-config-default + #'exwm-config-example "27.1") + +(defun exwm-config-example () + "Default configuration of EXWM." + ;; Set the initial workspace number. + (unless (get 'exwm-workspace-number 'saved-value) + (setq exwm-workspace-number 4)) + ;; Make class name the buffer name + (add-hook 'exwm-update-class-hook + (lambda () + (exwm-workspace-rename-buffer exwm-class-name))) + ;; Global keybindings. + (unless (get 'exwm-input-global-keys 'saved-value) + (setq exwm-input-global-keys + `( + ;; 's-r': Reset (to line-mode). + ([?\s-r] . exwm-reset) + ;; 's-w': Switch workspace. + ([?\s-w] . exwm-workspace-switch) + ;; 's-&': Launch application. + ([?\s-&] . (lambda (command) + (interactive (list (read-shell-command "$ "))) + (start-process-shell-command command nil command))) + ;; 's-N': Switch to certain workspace. + ,@(mapcar (lambda (i) + `(,(kbd (format "s-%d" i)) . + (lambda () + (interactive) + (exwm-workspace-switch-create ,i)))) + (number-sequence 0 9))))) + ;; Line-editing shortcuts + (unless (get 'exwm-input-simulation-keys 'saved-value) + (setq exwm-input-simulation-keys + '(([?\C-b] . [left]) + ([?\C-f] . [right]) + ([?\C-p] . [up]) + ([?\C-n] . [down]) + ([?\C-a] . [home]) + ([?\C-e] . [end]) + ([?\M-v] . [prior]) + ([?\C-v] . [next]) + ([?\C-d] . [delete]) + ([?\C-k] . [S-end delete])))) + ;; Enable EXWM + (exwm-enable) + ;; Configure Ido + (exwm-config-ido) + ;; Other configurations + (exwm-config-misc)) + +(defun exwm-config--fix/ido-buffer-window-other-frame () + "Fix `ido-buffer-window-other-frame'." + (defalias 'exwm-config-ido-buffer-window-other-frame + (symbol-function #'ido-buffer-window-other-frame)) + (defun ido-buffer-window-other-frame (buffer) + "This is a version redefined by EXWM. + +You can find the original one at `exwm-config-ido-buffer-window-other-frame'." + (with-current-buffer (window-buffer (selected-window)) + (if (and (derived-mode-p 'exwm-mode) + exwm--floating-frame) + ;; Switch from a floating frame. + (with-current-buffer buffer + (if (and (derived-mode-p 'exwm-mode) + exwm--floating-frame + (eq exwm--frame exwm-workspace--current)) + ;; Switch to another floating frame. + (frame-root-window exwm--floating-frame) + ;; Do not switch if the buffer is not on the current workspace. + (or (get-buffer-window buffer exwm-workspace--current) + (selected-window)))) + (with-current-buffer buffer + (when (derived-mode-p 'exwm-mode) + (if (eq exwm--frame exwm-workspace--current) + (when exwm--floating-frame + ;; Switch to a floating frame on the current workspace. + (frame-selected-window exwm--floating-frame)) + ;; Do not switch to exwm-mode buffers on other workspace (which + ;; won't work unless `exwm-layout-show-all-buffers' is set) + (unless exwm-layout-show-all-buffers + (selected-window))))))))) + +(defun exwm-config-ido () + "Configure Ido to work with EXWM." + (ido-mode 1) + (add-hook 'exwm-init-hook #'exwm-config--fix/ido-buffer-window-other-frame)) + +(defun exwm-config-misc () + "Other configurations." + ;; Make more room + (menu-bar-mode -1) + (tool-bar-mode -1) + (scroll-bar-mode -1) + (fringe-mode 1)) + + + +(provide 'exwm-config) + +;;; exwm-config.el ends here diff --git a/third_party/exwm/exwm-core.el b/third_party/exwm/exwm-core.el new file mode 100644 index 0000000000..e0d644d941 --- /dev/null +++ b/third_party/exwm/exwm-core.el @@ -0,0 +1,411 @@ +;;; exwm-core.el --- Core definitions -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2024 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module includes core definitions of variables, macros, functions, etc +;; shared by various other modules. + +;;; Code: + +(require 'kmacro) + +(require 'xcb) +(require 'xcb-icccm) +(require 'xcb-ewmh) +(require 'xcb-debug) + +(defgroup exwm-debug nil + "Debugging." + :group 'exwm) + +(defcustom exwm-debug-log-time-function #'exwm-debug-log-uptime + "Function used for generating timestamps in `exwm-debug' logs. + +Here are some predefined candidates: +`exwm-debug-log-uptime': Display the uptime of this Emacs instance. +`exwm-debug-log-time': Display time of day. +`nil': Disable timestamp." + :type `(choice (const :tag "Emacs uptime" ,#'exwm-debug-log-uptime) + (const :tag "Time of day" ,#'exwm-debug-log-time) + (const :tag "Off" nil) + (function :tag "Other")) + :set (lambda (symbol value) + (set-default symbol value) + ;; Also change the format for XELB to make logs consistent + ;; (as they share the same buffer). + (setq xcb-debug:log-time-function value))) + +(defalias 'exwm-debug-log-uptime 'xcb-debug:log-uptime + "Add uptime to `exwm-debug' logs.") + +(defalias 'exwm-debug-log-time 'xcb-debug:log-time + "Add time of day to `exwm-debug' logs.") + +(defvar exwm--connection nil "X connection.") + +(defvar exwm--terminal nil + "Terminal corresponding to `exwm--connection'.") + +(defvar exwm--wmsn-window nil + "An X window owning the WM_S0 selection.") + +(defvar exwm--wmsn-acquire-timeout 3 + "Number of seconds to wait for other window managers to release the selection.") + +(defvar exwm--guide-window nil + "An X window separating workspaces and X windows.") + +(defvar exwm--id-buffer-alist nil "Alist of (<X window ID> . <Emacs buffer>).") + +(defvar exwm--root nil "Root window.") + +(defvar exwm-input--global-prefix-keys) +(defvar exwm-input--simulation-keys) +(defvar exwm-input-line-mode-passthrough) +(defvar exwm-input-prefix-keys) +(declare-function exwm-input--fake-key "exwm-input.el" (event)) +(declare-function exwm-input--on-KeyPress-line-mode "exwm-input.el" + (key-press raw-data)) +(declare-function exwm-floating-hide "exwm-floating.el") +(declare-function exwm-floating-toggle-floating "exwm-floating.el") +(declare-function exwm-input-release-keyboard "exwm-input.el") +(declare-function exwm-input-send-next-key "exwm-input.el" (times)) +(declare-function exwm-layout-set-fullscreen "exwm-layout.el" (&optional id)) +(declare-function exwm-layout-toggle-mode-line "exwm-layout.el") +(declare-function exwm-manage--kill-buffer-query-function "exwm-manage.el") +(declare-function exwm-workspace-move-window "exwm-workspace.el" + (frame-or-index &optional id)) + +(define-minor-mode exwm-debug + "Debug-logging enabled if non-nil." + :global t + :group 'exwm-debug) + +(defmacro exwm--debug (&rest forms) + "Evaluate FORMS if mode `exwm-debug' is active." + (when exwm-debug `(progn ,@forms))) + +(defmacro exwm--log (&optional format-string &rest objects) + "Emit a message prepending the name of the function being executed. + +FORMAT-STRING is a string specifying the message to output, as in +`format'. The OBJECTS arguments specify the substitutions." + (unless format-string (setq format-string "")) + `(when exwm-debug + (xcb-debug:message ,(concat "%s%s:\t" format-string "\n") + (if exwm-debug-log-time-function + (funcall exwm-debug-log-time-function) + "") + (xcb-debug:compile-time-function-name) + ,@objects) + nil)) + +(defsubst exwm--id->buffer (id) + "X window ID => Emacs buffer." + (declare (indent defun)) + (cdr (assoc id exwm--id-buffer-alist))) + +(defsubst exwm--buffer->id (buffer) + "Emacs buffer BUFFER => X window ID." + (declare (indent defun)) + (car (rassoc buffer exwm--id-buffer-alist))) + +(defun exwm--lock (&rest _args) + "Lock (disable all events)." + (exwm--log) + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window exwm--root + :value-mask xcb:CW:EventMask + :event-mask xcb:EventMask:NoEvent)) + (xcb:flush exwm--connection)) + +(defun exwm--unlock (&rest _args) + "Unlock (enable all events)." + (exwm--log) + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window exwm--root + :value-mask xcb:CW:EventMask + :event-mask (eval-when-compile + (logior xcb:EventMask:SubstructureRedirect + xcb:EventMask:StructureNotify)))) + (xcb:flush exwm--connection)) + +(defun exwm--set-geometry (xwin x y width height) + "Set the geometry of X window XWIN to WIDTHxHEIGHT+X+Y. + +Nil can be passed as placeholder." + (exwm--log "Setting #x%x to %sx%s+%s+%s" xwin width height x y) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window xwin + :value-mask (logior (if x xcb:ConfigWindow:X 0) + (if y xcb:ConfigWindow:Y 0) + (if width xcb:ConfigWindow:Width 0) + (if height xcb:ConfigWindow:Height 0)) + :x x :y y :width width :height height))) + +(defun exwm--intern-atom (atom &optional conn) + "Intern X11 ATOM. +If CONN is non-nil, use it instead of the value of the variable +`exwm--connection'." + (slot-value (xcb:+request-unchecked+reply (or conn exwm--connection) + (make-instance 'xcb:InternAtom + :only-if-exists 0 + :name-len (length atom) + :name atom)) + 'atom)) + +(defmacro exwm--defer (secs function &rest args) + "Defer the execution of FUNCTION. + +The action is to call FUNCTION with arguments ARGS. If Emacs is not idle, +defer the action until Emacs is idle. Otherwise, defer the action until at +least SECS seconds later." + `(run-with-idle-timer (+ (float-time (or (current-idle-time) + (seconds-to-time (- ,secs)))) + ,secs) + nil + ,function + ,@args)) + +(defsubst exwm--terminal-p (&optional frame) + "Return t when FRAME's terminal is EXWM's terminal. +If FRAME is null, use selected frame." + (declare (indent defun)) + (eq exwm--terminal (frame-terminal frame))) + +(defun exwm--get-client-event-mask () + "Return event mask set on all managed windows." + (logior xcb:EventMask:StructureNotify + xcb:EventMask:PropertyChange + (if mouse-autoselect-window + xcb:EventMask:EnterWindow 0))) + +(defun exwm--color->pixel (color) + "Convert COLOR to PIXEL (index in TrueColor colormap)." + (when (and color + (eq (x-display-visual-class) 'true-color)) + (let ((rgb (color-values color))) + (logior (ash (ash (pop rgb) -8) 16) + (ash (ash (pop rgb) -8) 8) + (ash (pop rgb) -8))))) + +(defun exwm--get-visual-depth-colormap (conn id) + "Get visual, depth and colormap from X window ID. +Return a three element list with the respective results. + +If CONN is non-nil, use it instead of the value of the variable +`exwm--connection'." + (let (ret-visual ret-depth ret-colormap) + (with-slots (visual colormap) + (xcb:+request-unchecked+reply conn + (make-instance 'xcb:GetWindowAttributes :window id)) + (setq ret-visual visual) + (setq ret-colormap colormap)) + (with-slots (depth) + (xcb:+request-unchecked+reply conn + (make-instance 'xcb:GetGeometry :drawable id)) + (setq ret-depth depth)) + (list ret-visual ret-depth ret-colormap))) + +;; Internal variables +(defvar-local exwm--id nil) ;window ID +(defvar-local exwm--configurations nil) ;initial configurations. +(defvar-local exwm--frame nil) ;workspace frame +(defvar-local exwm--floating-frame nil) ;floating frame +(defvar-local exwm--mode-line-format nil) ;save mode-line-format +(defvar-local exwm--floating-frame-position nil) ;set when hidden. +(defvar-local exwm--fixed-size nil) ;fixed size +(defvar-local exwm--selected-input-mode 'line-mode + "Input mode as selected by the user. +One of `line-mode' or `char-mode'.") +(defvar-local exwm--input-mode 'line-mode + "Actual input mode, i.e. whether mouse and keyboard are grabbed.") +;; Properties +(defvar-local exwm--desktop nil "_NET_WM_DESKTOP.") +(defvar-local exwm-window-type nil "_NET_WM_WINDOW_TYPE.") +(defvar-local exwm--geometry nil) +(defvar-local exwm-class-name nil "Class name in WM_CLASS.") +(defvar-local exwm-instance-name nil "Instance name in WM_CLASS.") +(defvar-local exwm-title nil "Window title (either _NET_WM_NAME or WM_NAME).") +(defvar-local exwm--title-is-utf8 nil) +(defvar-local exwm-transient-for nil "WM_TRANSIENT_FOR.") +(defvar-local exwm--protocols nil) +(defvar-local exwm-state xcb:icccm:WM_STATE:NormalState "WM_STATE.") +(defvar-local exwm--ewmh-state nil "_NET_WM_STATE.") +;; _NET_WM_NORMAL_HINTS +(defvar-local exwm--normal-hints-x nil) +(defvar-local exwm--normal-hints-y nil) +(defvar-local exwm--normal-hints-width nil) +(defvar-local exwm--normal-hints-height nil) +(defvar-local exwm--normal-hints-min-width nil) +(defvar-local exwm--normal-hints-min-height nil) +(defvar-local exwm--normal-hints-max-width nil) +(defvar-local exwm--normal-hints-max-height nil) +;; (defvar-local exwm--normal-hints-win-gravity nil) +;; WM_HINTS +(defvar-local exwm--hints-input nil) +(defvar-local exwm--hints-urgency nil) +;; _MOTIF_WM_HINTS +(defvar-local exwm--mwm-hints-decorations t) + +(defvar exwm-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-c\C-d\C-l" #'xcb-debug:clear) + (define-key map "\C-c\C-d\C-m" #'xcb-debug:mark) + (define-key map "\C-c\C-d\C-t" #'exwm-debug) + (define-key map "\C-c\C-f" #'exwm-layout-set-fullscreen) + (define-key map "\C-c\C-h" #'exwm-floating-hide) + (define-key map "\C-c\C-k" #'exwm-input-release-keyboard) + (define-key map "\C-c\C-m" #'exwm-workspace-move-window) + (define-key map "\C-c\C-q" #'exwm-input-send-next-key) + (define-key map "\C-c\C-t\C-f" #'exwm-floating-toggle-floating) + (define-key map "\C-c\C-t\C-m" #'exwm-layout-toggle-mode-line) + map) + "Keymap for `exwm-mode'.") + +(defvar exwm--kmacro-map + (let ((map (make-sparse-keymap))) + (define-key map [t] + (lambda () + (interactive) + (cond + ((or exwm-input-line-mode-passthrough + ;; Do not test `exwm-input--during-command'. + (active-minibuffer-window) + (memq last-input-event exwm-input--global-prefix-keys) + (memq last-input-event exwm-input-prefix-keys) + (lookup-key exwm-mode-map (vector last-input-event)) + (gethash last-input-event exwm-input--simulation-keys)) + (set-transient-map (make-composed-keymap (list exwm-mode-map + global-map))) + (push last-input-event unread-command-events)) + (t + (exwm-input--fake-key last-input-event))))) + map) + "Keymap used when executing keyboard macros.") + +;; This menu mainly acts as an reminder for users. Thus it should be as +;; detailed as possible, even some entries do not make much sense here. +;; Also, inactive entries should be disabled rather than hidden. +(easy-menu-define exwm-mode-menu exwm-mode-map + "Menu for `exwm-mode'." + '("EXWM" + "---" + "*General*" + "---" + ["Toggle floating" exwm-floating-toggle-floating] + ["Toggle fullscreen mode" exwm-layout-toggle-fullscreen] + ["Hide window" exwm-floating-hide exwm--floating-frame] + ["Close window" (kill-buffer (current-buffer))] + + "---" + "*Resizing*" + "---" + ["Toggle mode-line" exwm-layout-toggle-mode-line] + ["Enlarge window vertically" exwm-layout-enlarge-window] + ["Enlarge window horizontally" exwm-layout-enlarge-window-horizontally] + ["Shrink window vertically" exwm-layout-shrink-window] + ["Shrink window horizontally" exwm-layout-shrink-window-horizontally] + + "---" + "*Keyboard*" + "---" + ["Toggle keyboard mode" exwm-input-toggle-keyboard] + ["Send key" exwm-input-send-next-key (eq exwm--input-mode 'line-mode)] + ;; This is merely a reference. + ("Send simulation key" :filter + (lambda (&rest _args) + (let (result) + (maphash + (lambda (key value) + (when (sequencep key) + (setq result (append result + `([ + ,(format "Send '%s'" + (key-description value)) + (lambda () + (interactive) + (dolist (i ',value) + (exwm-input--fake-key i))) + :keys ,(key-description key)]))))) + exwm-input--simulation-keys) + result))) + + ["Define global binding" exwm-input-set-key] + + "---" + "*Workspace*" + "---" + ["Add workspace" exwm-workspace-add] + ["Delete current workspace" exwm-workspace-delete] + ["Move workspace to" exwm-workspace-move] + ["Swap workspaces" exwm-workspace-swap] + ["Move X window to" exwm-workspace-move-window] + ["Move X window from" exwm-workspace-switch-to-buffer] + ["Toggle minibuffer" exwm-workspace-toggle-minibuffer] + ["Switch workspace" exwm-workspace-switch] + ;; Place this entry at bottom to avoid selecting others by accident. + ("Switch to" :filter + (lambda (&rest _args) + (mapcar (lambda (i) + `[,(format "Workspace %d" i) + (lambda () + (interactive) + (exwm-workspace-switch ,i)) + (/= ,i exwm-workspace-current-index)]) + (number-sequence 0 (1- (exwm-workspace--count)))))))) + +(define-derived-mode exwm-mode nil "EXWM" + "Major mode for managing X windows. + +\\{exwm-mode-map}" + ;; + (setq mode-name + '(:eval (propertize "EXWM" 'face + (when (cl-some (lambda (i) + (frame-parameter i 'exwm-urgency)) + exwm-workspace--list) + 'font-lock-warning-face)))) + ;; Change major-mode is not allowed + (add-hook 'change-major-mode-hook #'kill-buffer nil t) + ;; Kill buffer -> close window + (add-hook 'kill-buffer-query-functions + #'exwm-manage--kill-buffer-query-function nil t) + ;; Redirect events when executing keyboard macros. + (push `(executing-kbd-macro . ,exwm--kmacro-map) + minor-mode-overriding-map-alist) + (setq buffer-read-only t + cursor-type nil + left-margin-width nil + right-margin-width nil + left-fringe-width 0 + right-fringe-width 0 + vertical-scroll-bar nil)) + + + +(provide 'exwm-core) + +;;; exwm-core.el ends here diff --git a/third_party/exwm/exwm-floating.el b/third_party/exwm/exwm-floating.el new file mode 100644 index 0000000000..34d06a30db --- /dev/null +++ b/third_party/exwm/exwm-floating.el @@ -0,0 +1,780 @@ +;;; exwm-floating.el --- Floating Module for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2024 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module deals with the conversion between floating and non-floating +;; states and implements moving/resizing operations on floating windows. + +;;; Code: + +(require 'xcb-cursor) +(require 'exwm-core) + +(defgroup exwm-floating nil + "Floating." + :group 'exwm) + +(defcustom exwm-floating-setup-hook nil + "Normal hook run when an X window has been made floating. +This hook runs in the context of the corresponding buffer." + :type 'hook) + +(defcustom exwm-floating-exit-hook nil + "Normal hook run when an X window has exited floating state. +This hook runs in the context of the corresponding buffer." + :type 'hook) + +(defcustom exwm-floating-border-color "navy" + "Border color of floating windows." + :type 'color + :initialize #'custom-initialize-default + :set (lambda (symbol value) + (set-default symbol value) + ;; Change border color for all floating X windows. + (when exwm--connection + (let ((border-pixel (exwm--color->pixel value))) + (when border-pixel + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (when exwm--floating-frame + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window + (frame-parameter exwm--floating-frame + 'exwm-container) + :value-mask xcb:CW:BorderPixel + :border-pixel border-pixel))))) + (xcb:flush exwm--connection)))))) + +(defcustom exwm-floating-border-width 1 + "Border width of floating windows." + :type '(integer + :validate (lambda (widget) + (when (< (widget-value widget) 0) + (widget-put widget :error "Border width is at least 0") + widget))) + :initialize #'custom-initialize-default + :set (lambda (symbol value) + (let ((delta (- value exwm-floating-border-width)) + container) + (set-default symbol value) + ;; Change border width for all floating X windows. + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (when exwm--floating-frame + (setq container (frame-parameter exwm--floating-frame + 'exwm-container)) + (with-slots (x y) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable container)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window container + :value-mask + (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Y + xcb:ConfigWindow:BorderWidth) + :border-width value + :x (- x delta) + :y (- y delta))))))) + (when exwm--connection + (xcb:flush exwm--connection))))) + +;; Cursors for moving/resizing a window +(defvar exwm-floating--cursor-move nil) +(defvar exwm-floating--cursor-top-left nil) +(defvar exwm-floating--cursor-top nil) +(defvar exwm-floating--cursor-top-right nil) +(defvar exwm-floating--cursor-right nil) +(defvar exwm-floating--cursor-bottom-right nil) +(defvar exwm-floating--cursor-bottom nil) +(defvar exwm-floating--cursor-bottom-left nil) +(defvar exwm-floating--cursor-left nil) + +(defvar exwm-floating--moveresize-calculate nil + "Calculate move/resize parameters [buffer event-mask x y width height].") + +(defvar exwm-workspace--current) +(defvar exwm-workspace--frame-y-offset) +(defvar exwm-workspace--window-y-offset) +(declare-function exwm-layout--hide "exwm-layout.el" (id)) +(declare-function exwm-layout--iconic-state-p "exwm-layout.el" (&optional id)) +(declare-function exwm-layout--refresh "exwm-layout.el" ()) +(declare-function exwm-layout--show "exwm-layout.el" (id &optional window)) +(declare-function exwm-workspace--position "exwm-workspace.el" (frame)) +(declare-function exwm-workspace--update-offsets "exwm-workspace.el" ()) +(declare-function exwm-workspace--workarea "exwm-workspace.el" (frame)) + +(defun exwm-floating--set-allowed-actions (id tilling) + "Set _NET_WM_ALLOWED_ACTIONS." + (exwm--log "#x%x" id) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_ALLOWED_ACTIONS + :window id + :data (if tilling + (vector xcb:Atom:_NET_WM_ACTION_MINIMIZE + xcb:Atom:_NET_WM_ACTION_FULLSCREEN + xcb:Atom:_NET_WM_ACTION_CHANGE_DESKTOP + xcb:Atom:_NET_WM_ACTION_CLOSE) + (vector xcb:Atom:_NET_WM_ACTION_MOVE + xcb:Atom:_NET_WM_ACTION_RESIZE + xcb:Atom:_NET_WM_ACTION_MINIMIZE + xcb:Atom:_NET_WM_ACTION_FULLSCREEN + xcb:Atom:_NET_WM_ACTION_CHANGE_DESKTOP + xcb:Atom:_NET_WM_ACTION_CLOSE))))) + +(defun exwm-floating--set-floating (id) + "Make window ID floating." + (let ((window (get-buffer-window (exwm--id->buffer id)))) + (when window + ;; Hide the non-floating X window first. + (set-window-buffer window (other-buffer nil t)))) + (let* ((original-frame (buffer-local-value 'exwm--frame + (exwm--id->buffer id))) + ;; Create new frame + (frame (with-current-buffer + (or (get-buffer "*scratch*") + (progn + (set-buffer-major-mode + (get-buffer-create "*scratch*")) + (get-buffer "*scratch*"))) + (make-frame + `((minibuffer . ,(minibuffer-window exwm--frame)) + (tab-bar-lines . 0) + (tab-bar-lines-keep-state . t) + (left . ,(* window-min-width -10000)) + (top . ,(* window-min-height -10000)) + (width . ,window-min-width) + (height . ,window-min-height) + (unsplittable . t))))) ;and fix the size later + (outer-id (string-to-number (frame-parameter frame 'outer-window-id))) + (window-id (string-to-number (frame-parameter frame 'window-id))) + (frame-container (xcb:generate-id exwm--connection)) + (window (frame-first-window frame)) ;and it's the only window + (x (slot-value exwm--geometry 'x)) + (y (slot-value exwm--geometry 'y)) + (width (slot-value exwm--geometry 'width)) + (height (slot-value exwm--geometry 'height))) + ;; Force drawing menu-bar & tool-bar. + (redisplay t) + (exwm-workspace--update-offsets) + (exwm--log "Floating geometry (original): %dx%d%+d%+d" width height x y) + ;; Save frame parameters. + (set-frame-parameter frame 'exwm-outer-id outer-id) + (set-frame-parameter frame 'exwm-id window-id) + (set-frame-parameter frame 'exwm-container frame-container) + ;; Fix illegal parameters + ;; FIXME: check normal hints restrictions + (with-slots ((x* x) (y* y) (width* width) (height* height)) + (exwm-workspace--workarea original-frame) + ;; Center floating windows + (when (and (or (= x 0) (= x x*)) + (or (= y 0) (= y y*))) + (let ((buffer (exwm--id->buffer exwm-transient-for)) + window edges) + (when (and buffer (setq window (get-buffer-window buffer))) + (setq edges (window-inside-absolute-pixel-edges window)) + (unless (and (<= width (- (elt edges 2) (elt edges 0))) + (<= height (- (elt edges 3) (elt edges 1)))) + (setq edges nil))) + (if edges + ;; Put at the center of leading window + (setq x (+ x* (/ (- (elt edges 2) (elt edges 0) width) 2)) + y (+ y* (/ (- (elt edges 3) (elt edges 1) height) 2))) + ;; Put at the center of screen + (setq x (/ (- width* width) 2) + y (/ (- height* height) 2))))) + (if (> width width*) + ;; Too wide + (progn (setq x x* + width width*)) + ;; Invalid width + (when (= 0 width) (setq width (/ width* 2))) + ;; Make sure at least half of the window is visible + (unless (< x* (+ x (/ width 2)) (+ x* width*)) + (setq x (+ x* (/ (- width* width) 2))))) + (if (> height height*) + ;; Too tall + (setq y y* + height height*) + ;; Invalid height + (when (= 0 height) (setq height (/ height* 2))) + ;; Make sure at least half of the window is visible + (unless (< y* (+ y (/ height 2)) (+ y* height*)) + (setq y (+ y* (/ (- height* height) 2))))) + ;; The geometry can be overridden by user options. + (let ((x** (plist-get exwm--configurations 'x)) + (y** (plist-get exwm--configurations 'y)) + (width** (plist-get exwm--configurations 'width)) + (height** (plist-get exwm--configurations 'height))) + (if (integerp x**) + (setq x (+ x* x**)) + (when (and (floatp x**) + (>= 1 x** 0)) + (setq x (+ x* (round (* x** width*)))))) + (if (integerp y**) + (setq y (+ y* y**)) + (when (and (floatp y**) + (>= 1 y** 0)) + (setq y (+ y* (round (* y** height*)))))) + (if (integerp width**) + (setq width width**) + (when (and (floatp width**) + (> 1 width** 0)) + (setq width (max 1 (round (* width** width*)))))) + (if (integerp height**) + (setq height height**) + (when (and (floatp height**) + (> 1 height** 0)) + (setq height (max 1 (round (* height** height*)))))))) + (exwm--set-geometry id x y nil nil) + (xcb:flush exwm--connection) + (exwm--log "Floating geometry (corrected): %dx%d%+d%+d" width height x y) + ;; Fit frame to client + ;; It seems we have to make the frame invisible in order to resize it + ;; timely. + ;; The frame will be made visible by `select-frame-set-input-focus'. + (make-frame-invisible frame) + (let* ((edges (window-inside-pixel-edges window)) + (frame-width (+ width (- (frame-pixel-width frame) + (- (elt edges 2) (elt edges 0))))) + (frame-height (+ height (- (frame-pixel-height frame) + (- (elt edges 3) (elt edges 1))) + ;; Use `frame-outer-height' in the future. + exwm-workspace--frame-y-offset)) + (floating-mode-line (plist-get exwm--configurations + 'floating-mode-line)) + (floating-header-line (plist-get exwm--configurations + 'floating-header-line)) + (border-pixel (exwm--color->pixel exwm-floating-border-color))) + (if floating-mode-line + (setq exwm--mode-line-format (or exwm--mode-line-format + mode-line-format) + mode-line-format floating-mode-line) + (if (and (not (plist-member exwm--configurations 'floating-mode-line)) + exwm--mwm-hints-decorations) + (when exwm--mode-line-format + (setq mode-line-format exwm--mode-line-format)) + ;; The mode-line need to be hidden in floating mode. + (setq frame-height (- frame-height (window-mode-line-height + (frame-root-window frame))) + exwm--mode-line-format (or exwm--mode-line-format + mode-line-format) + mode-line-format nil))) + (if floating-header-line + (setq header-line-format floating-header-line) + (if (and (not (plist-member exwm--configurations + 'floating-header-line)) + exwm--mwm-hints-decorations) + (setq header-line-format nil) + ;; The header-line need to be hidden in floating mode. + (setq frame-height (- frame-height (window-header-line-height + (frame-root-window frame))) + header-line-format nil))) + (set-frame-size frame frame-width frame-height t) + ;; Create the frame container as the parent of the frame. + (xcb:+request exwm--connection + (make-instance 'xcb:CreateWindow + :depth 0 + :wid frame-container + :parent exwm--root + :x x + :y (- y exwm-workspace--window-y-offset) + :width width + :height height + :border-width + (with-current-buffer (exwm--id->buffer id) + (let ((border-witdh (plist-get exwm--configurations + 'border-width))) + (if (and (integerp border-witdh) + (>= border-witdh 0)) + border-witdh + exwm-floating-border-width))) + :class xcb:WindowClass:InputOutput + :visual 0 + :value-mask (logior xcb:CW:BackPixmap + (if border-pixel + xcb:CW:BorderPixel 0) + xcb:CW:OverrideRedirect) + :background-pixmap xcb:BackPixmap:ParentRelative + :border-pixel border-pixel + :override-redirect 1)) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window frame-container + :data + (format "EXWM floating frame container for 0x%x" id))) + ;; Map it. + (xcb:+request exwm--connection + (make-instance 'xcb:MapWindow :window frame-container)) + ;; Put the X window right above this frame container. + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window id + :value-mask (logior xcb:ConfigWindow:Sibling + xcb:ConfigWindow:StackMode) + :sibling frame-container + :stack-mode xcb:StackMode:Above))) + ;; Reparent this frame to its container. + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window outer-id :parent frame-container :x 0 :y 0)) + (exwm-floating--set-allowed-actions id nil) + (xcb:flush exwm--connection) + ;; Set window/buffer + (with-current-buffer (exwm--id->buffer id) + (setq window-size-fixed exwm--fixed-size + exwm--floating-frame frame) + ;; Do the refresh manually. + (remove-hook 'window-configuration-change-hook #'exwm-layout--refresh) + (set-window-buffer window (current-buffer)) ;this changes current buffer + (add-hook 'window-configuration-change-hook #'exwm-layout--refresh) + (set-window-dedicated-p window t) + (exwm-layout--show id window)) + (with-current-buffer (exwm--id->buffer id) + (if (exwm-layout--iconic-state-p id) + ;; Hide iconic floating X windows. + (exwm-floating-hide) + (with-selected-frame exwm--frame + (exwm-layout--refresh))) + (select-frame-set-input-focus frame)) + ;; FIXME: Strangely, the Emacs frame can move itself at this point + ;; when there are left/top struts set. Force resetting its + ;; position seems working, but it'd better to figure out why. + ;; FIXME: This also happens in another case (#220) where the cause is + ;; still unclear. + (exwm--set-geometry outer-id 0 0 nil nil) + (xcb:flush exwm--connection)) + (with-current-buffer (exwm--id->buffer id) + (run-hooks 'exwm-floating-setup-hook)) + ;; Redraw the frame. + (redisplay t)) + +(defun exwm-floating--unset-floating (id) + "Make window ID non-floating." + (exwm--log "#x%x" id) + (let ((buffer (exwm--id->buffer id))) + (with-current-buffer buffer + (when exwm--floating-frame + ;; The X window is already mapped. + ;; Unmap the X window. + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window id :value-mask xcb:CW:EventMask + :event-mask xcb:EventMask:NoEvent)) + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow :window id)) + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window id :value-mask xcb:CW:EventMask + :event-mask (exwm--get-client-event-mask))) + ;; Reparent the floating frame back to the root window. + (let ((frame-id (frame-parameter exwm--floating-frame 'exwm-outer-id)) + (frame-container (frame-parameter exwm--floating-frame + 'exwm-container))) + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow :window frame-id)) + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window frame-id + :parent exwm--root + :x 0 :y 0)) + ;; Also destroy its container. + (xcb:+request exwm--connection + (make-instance 'xcb:DestroyWindow :window frame-container)))) + ;; Place the X window just above the reference X window. + ;; (the stacking order won't change from now on). + ;; Also hide the possible floating border. + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window id + :value-mask (logior xcb:ConfigWindow:BorderWidth + xcb:ConfigWindow:Sibling + xcb:ConfigWindow:StackMode) + :border-width 0 + :sibling exwm--guide-window + :stack-mode xcb:StackMode:Above))) + (exwm-floating--set-allowed-actions id t) + (xcb:flush exwm--connection) + (with-current-buffer buffer + (when exwm--floating-frame ;from floating to non-floating + (set-window-dedicated-p (frame-first-window exwm--floating-frame) nil) + ;; Select a tiling window and delete the old frame. + (select-window (frame-selected-window exwm-workspace--current)) + (with-current-buffer buffer + (delete-frame exwm--floating-frame)))) + (with-current-buffer buffer + (setq window-size-fixed nil + exwm--floating-frame nil) + (if (not (plist-member exwm--configurations 'tiling-mode-line)) + (when exwm--mode-line-format + (setq mode-line-format exwm--mode-line-format)) + (setq exwm--mode-line-format (or exwm--mode-line-format + mode-line-format) + mode-line-format (plist-get exwm--configurations + 'tiling-mode-line))) + (if (not (plist-member exwm--configurations 'tiling-header-line)) + (setq header-line-format nil) + (setq header-line-format (plist-get exwm--configurations + 'tiling-header-line)))) + ;; Only show X windows in normal state. + (unless (exwm-layout--iconic-state-p) + (pop-to-buffer-same-window buffer))) + (with-current-buffer (exwm--id->buffer id) + (run-hooks 'exwm-floating-exit-hook))) + +;;;###autoload +(cl-defun exwm-floating-toggle-floating () + "Toggle the current window between floating and non-floating states." + (interactive) + (exwm--log) + (unless (derived-mode-p 'exwm-mode) + (cl-return-from exwm-floating-toggle-floating)) + (with-current-buffer (window-buffer) + (if exwm--floating-frame + (exwm-floating--unset-floating exwm--id) + (exwm-floating--set-floating exwm--id)))) + +;;;###autoload +(defun exwm-floating-hide () + "Hide the current floating X window (which would show again when selected)." + (interactive) + (exwm--log) + (when (and (derived-mode-p 'exwm-mode) + exwm--floating-frame) + (exwm-layout--hide exwm--id) + (select-frame-set-input-focus exwm-workspace--current))) + +(defun exwm-floating--start-moveresize (id &optional type) + "Start move/resize." + (exwm--log "#x%x" id) + (let ((buffer-or-id (or (exwm--id->buffer id) id)) + frame container-or-id x y width height cursor) + (if (bufferp buffer-or-id) + ;; Managed. + (with-current-buffer buffer-or-id + (setq frame exwm--floating-frame + container-or-id (frame-parameter exwm--floating-frame + 'exwm-container))) + ;; Unmanaged. + (setq container-or-id id)) + (when (and container-or-id + ;; Test if the pointer can be grabbed + (= xcb:GrabStatus:Success + (slot-value + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GrabPointer + :owner-events 0 + :grab-window container-or-id + :event-mask xcb:EventMask:NoEvent + :pointer-mode xcb:GrabMode:Async + :keyboard-mode xcb:GrabMode:Async + :confine-to xcb:Window:None + :cursor xcb:Cursor:None + :time xcb:Time:CurrentTime)) + 'status))) + (with-slots (root-x root-y win-x win-y) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:QueryPointer :window id)) + (if (not (bufferp buffer-or-id)) + ;; Unmanaged. + (unless (eq type xcb:ewmh:_NET_WM_MOVERESIZE_MOVE) + (with-slots ((width* width) + (height* height)) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry :drawable id)) + (setq width width* + height height*))) + ;; Managed. + (select-window (frame-first-window frame)) ;transfer input focus + (setq width (frame-pixel-width frame) + height (frame-pixel-height frame)) + (unless type + ;; Determine the resize type according to the pointer position + ;; Clicking the center 1/3 part to resize has no effect + (setq x (/ (* 3 win-x) (float width)) + y (/ (* 3 win-y) (float height)) + type (cond ((and (< x 1) (< y 1)) + xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOPLEFT) + ((and (> x 2) (< y 1)) + xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOPRIGHT) + ((and (> x 2) (> y 2)) + xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOMRIGHT) + ((and (< x 1) (> y 2)) + xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOMLEFT) + ((> x 2) xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_RIGHT) + ((> y 2) xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOM) + ((< x 1) xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_LEFT) + ((< y 1) xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOP))))) + (if (not type) + (exwm-floating--stop-moveresize) + (cond ((= type xcb:ewmh:_NET_WM_MOVERESIZE_MOVE) + (setq cursor exwm-floating--cursor-move + exwm-floating--moveresize-calculate + (lambda (x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Y)) + (- x win-x) (- y win-y) 0 0)))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOPLEFT) + (setq cursor exwm-floating--cursor-top-left + exwm-floating--moveresize-calculate + (lambda (x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Y + xcb:ConfigWindow:Width + xcb:ConfigWindow:Height)) + (- x win-x) (- y win-y) + (- (+ root-x width) x) + (- (+ root-y height) y))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOP) + (setq cursor exwm-floating--cursor-top + exwm-floating--moveresize-calculate + (lambda (_x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:Y + xcb:ConfigWindow:Height)) + 0 (- y win-y) 0 (- (+ root-y height) y))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_TOPRIGHT) + (setq cursor exwm-floating--cursor-top-right + exwm-floating--moveresize-calculate + (lambda (x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:Y + xcb:ConfigWindow:Width + xcb:ConfigWindow:Height)) + 0 (- y win-y) (- x (- root-x width)) + (- (+ root-y height) y))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_RIGHT) + (setq cursor exwm-floating--cursor-right + exwm-floating--moveresize-calculate + (lambda (x _y) + (vector buffer-or-id + xcb:ConfigWindow:Width + 0 0 (- x (- root-x width)) 0)))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOMRIGHT) + (setq cursor exwm-floating--cursor-bottom-right + exwm-floating--moveresize-calculate + (lambda (x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:Width + xcb:ConfigWindow:Height)) + 0 0 (- x (- root-x width)) + (- y (- root-y height)))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOM) + (setq cursor exwm-floating--cursor-bottom + exwm-floating--moveresize-calculate + (lambda (_x y) + (vector buffer-or-id + xcb:ConfigWindow:Height + 0 0 0 (- y (- root-y height)))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_BOTTOMLEFT) + (setq cursor exwm-floating--cursor-bottom-left + exwm-floating--moveresize-calculate + (lambda (x y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Width + xcb:ConfigWindow:Height)) + (- x win-x) + 0 + (- (+ root-x width) x) + (- y (- root-y height)))))) + ((= type xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_LEFT) + (setq cursor exwm-floating--cursor-left + exwm-floating--moveresize-calculate + (lambda (x _y) + (vector buffer-or-id + (eval-when-compile + (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Width)) + (- x win-x) 0 (- (+ root-x width) x) 0))))) + ;; Select events and change cursor (should always succeed) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GrabPointer + :owner-events 0 :grab-window container-or-id + :event-mask (eval-when-compile + (logior xcb:EventMask:ButtonRelease + xcb:EventMask:ButtonMotion)) + :pointer-mode xcb:GrabMode:Async + :keyboard-mode xcb:GrabMode:Async + :confine-to xcb:Window:None + :cursor cursor + :time xcb:Time:CurrentTime))))))) + +(defun exwm-floating--stop-moveresize (&rest _args) + "Stop move/resize." + (exwm--log) + (xcb:+request exwm--connection + (make-instance 'xcb:UngrabPointer :time xcb:Time:CurrentTime)) + (when exwm-floating--moveresize-calculate + (let (result buffer-or-id outer-id container-id) + (setq result (funcall exwm-floating--moveresize-calculate 0 0) + buffer-or-id (aref result 0)) + (when (bufferp buffer-or-id) + (with-current-buffer buffer-or-id + (setq outer-id (frame-parameter exwm--floating-frame 'exwm-outer-id) + container-id (frame-parameter exwm--floating-frame + 'exwm-container)) + (with-slots (x y width height border-width) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable container-id)) + ;; Notify Emacs frame about this the position change. + (xcb:+request exwm--connection + (make-instance 'xcb:SendEvent + :propagate 0 + :destination outer-id + :event-mask xcb:EventMask:StructureNotify + :event + (xcb:marshal + (make-instance 'xcb:ConfigureNotify + :event outer-id + :window outer-id + :above-sibling xcb:Window:None + :x (+ x border-width) + :y (+ y border-width) + :width width + :height height + :border-width 0 + :override-redirect 0) + exwm--connection))) + (xcb:flush exwm--connection)) + (exwm-layout--show exwm--id + (frame-root-window exwm--floating-frame))))) + (setq exwm-floating--moveresize-calculate nil))) + +(defun exwm-floating--do-moveresize (data _synthetic) + "Perform move/resize." + (when exwm-floating--moveresize-calculate + (let* ((obj (make-instance 'xcb:MotionNotify)) + result value-mask x y width height buffer-or-id container-or-id) + (xcb:unmarshal obj data) + (setq result (funcall exwm-floating--moveresize-calculate + (slot-value obj 'root-x) (slot-value obj 'root-y)) + buffer-or-id (aref result 0) + value-mask (aref result 1) + x (aref result 2) + y (aref result 3) + width (max 1 (aref result 4)) + height (max 1 (aref result 5))) + (if (not (bufferp buffer-or-id)) + ;; Unmanaged. + (setq container-or-id buffer-or-id) + ;; Managed. + (setq container-or-id + (with-current-buffer buffer-or-id + (frame-parameter exwm--floating-frame 'exwm-container)) + x (- x exwm-floating-border-width) + ;; Use `frame-outer-height' in the future. + y (- y exwm-floating-border-width + exwm-workspace--window-y-offset) + height (+ height exwm-workspace--window-y-offset))) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window container-or-id + :value-mask (aref result 1) + :x x + :y y + :width width + :height height)) + (when (bufferp buffer-or-id) + ;; Managed. + (setq value-mask (logand value-mask (logior xcb:ConfigWindow:Width + xcb:ConfigWindow:Height))) + (when (/= 0 value-mask) + (with-current-buffer buffer-or-id + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm--floating-frame + 'exwm-outer-id) + :value-mask value-mask + :width width + :height height))))) + (xcb:flush exwm--connection)))) + +(defun exwm-floating-move (&optional delta-x delta-y) + "Move a floating window right by DELTA-X pixels and down by DELTA-Y pixels. + +Both DELTA-X and DELTA-Y default to 1. This command should be bound locally." + (exwm--log "delta-x: %s, delta-y: %s" delta-x delta-y) + (unless (and (derived-mode-p 'exwm-mode) exwm--floating-frame) + (user-error "[EXWM] `exwm-floating-move' is only for floating X windows")) + (unless delta-x (setq delta-x 1)) + (unless delta-y (setq delta-y 1)) + (unless (and (= 0 delta-x) (= 0 delta-y)) + (let* ((floating-container (frame-parameter exwm--floating-frame + 'exwm-container)) + (geometry (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable floating-container))) + (edges (window-inside-absolute-pixel-edges))) + (with-slots (x y) geometry + (exwm--set-geometry floating-container + (+ x delta-x) (+ y delta-y) nil nil)) + (exwm--set-geometry exwm--id + (+ (pop edges) delta-x) + (+ (pop edges) delta-y) + nil nil)) + (xcb:flush exwm--connection))) + +(defun exwm-floating--init () + "Initialize floating module." + (exwm--log) + ;; Initialize cursors for moving/resizing a window + (xcb:cursor:init exwm--connection) + (setq exwm-floating--cursor-move + (xcb:cursor:load-cursor exwm--connection "fleur") + exwm-floating--cursor-top-left + (xcb:cursor:load-cursor exwm--connection "top_left_corner") + exwm-floating--cursor-top + (xcb:cursor:load-cursor exwm--connection "top_side") + exwm-floating--cursor-top-right + (xcb:cursor:load-cursor exwm--connection "top_right_corner") + exwm-floating--cursor-right + (xcb:cursor:load-cursor exwm--connection "right_side") + exwm-floating--cursor-bottom-right + (xcb:cursor:load-cursor exwm--connection "bottom_right_corner") + exwm-floating--cursor-bottom + (xcb:cursor:load-cursor exwm--connection "bottom_side") + exwm-floating--cursor-bottom-left + (xcb:cursor:load-cursor exwm--connection "bottom_left_corner") + exwm-floating--cursor-left + (xcb:cursor:load-cursor exwm--connection "left_side"))) + +(defun exwm-floating--exit () + "Exit the floating module." + (exwm--log)) + + + +(provide 'exwm-floating) + +;;; exwm-floating.el ends here diff --git a/third_party/exwm/exwm-input.el b/third_party/exwm/exwm-input.el new file mode 100644 index 0000000000..f1f035c91a --- /dev/null +++ b/third_party/exwm/exwm-input.el @@ -0,0 +1,1248 @@ +;;; exwm-input.el --- Input Module for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2024 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module deals with key/mouse matters, including: +;; + Input focus, +;; + Key/Button event handling, +;; + Key events filtering and simulation. + +;; Todo: +;; + Pointer simulation mode (e.g. 'C-c 1'/'C-c 2' for single/double click, +;; move with arrow keys). +;; + Simulation keys to mimic Emacs key bindings for text edit (redo, select, +;; cancel, clear, etc). Some of them are not present on common keyboard +;; (keycode = 0). May need to use XKB extension. + +;;; Code: + +(require 'xcb-keysyms) +(require 'exwm-core) + +(defgroup exwm-input nil + "Input." + :group 'exwm) + +(defcustom exwm-input-prefix-keys + '(?\C-x ?\C-u ?\C-h ?\M-x ?\M-` ?\M-& ?\M-:) + "List of prefix keys EXWM should forward to Emacs when in `line-mode'. + +The point is to make keys like 'C-x C-f' forwarded to Emacs in `line-mode'. +There is no need to add prefix keys for global/simulation keys or those +defined in `exwm-mode-map' here." + :type '(repeat key-sequence) + :get (lambda (symbol) + (mapcar #'vector (default-value symbol))) + :set (lambda (symbol value) + (set symbol (mapcar (lambda (i) + (if (sequencep i) + (aref i 0) + i)) + value)))) + +(defcustom exwm-input-move-event 's-down-mouse-1 + "Emacs event to start moving a window." + :type 'key-sequence + :get (lambda (symbol) + (let ((value (default-value symbol))) + (if (mouse-event-p value) + value + (vector value)))) + :set (lambda (symbol value) + (set symbol (if (sequencep value) + (aref value 0) + value)))) + +(defcustom exwm-input-resize-event 's-down-mouse-3 + "Emacs event to start resizing a window." + :type 'key-sequence + :get (lambda (symbol) + (let ((value (default-value symbol))) + (if (mouse-event-p value) + value + (vector value)))) + :set (lambda (symbol value) + (set symbol (if (sequencep value) + (aref value 0) + value)))) + +(defcustom exwm-input-line-mode-passthrough nil + "Non-nil makes `line-mode' forward all events to Emacs." + :type 'boolean) + +;; Input focus update requests should be accumulated for a short time +;; interval so that only the last one need to be processed. This not +;; improves the overall performance, but avoids the problem of input +;; focus loop, which is a result of the interaction with Emacs frames. +;; +;; FIXME: The time interval is hard to decide and perhaps machine-dependent. +;; A value too small can cause redundant updates of input focus, +;; and even worse, dead loops. OTOH a large value would bring +;; laggy experience. +(defconst exwm-input--update-focus-interval 0.01 + "Time interval (in seconds) for accumulating input focus update requests.") + +(defconst exwm-input--passthrough-functions '(read-char + read-char-exclusive + read-key-sequence-vector + read-key-sequence + read-event) + "Low-level read functions that must be exempted from EXWM input handling.") + +(defvar exwm-input--during-command nil + "Indicate whether between `pre-command-hook' and `post-command-hook'.") + +(defvar exwm-input--global-keys nil "Global key bindings.") + +(defvar exwm-input--global-prefix-keys nil + "List of prefix keys of global key bindings.") + +(defvar exwm-input--line-mode-cache nil "Cache for incomplete key sequence.") + +(defvar exwm-input--local-simulation-keys nil + "Whether simulation keys are local.") + +(defvar exwm-input--simulation-keys nil "Simulation keys in `line-mode'.") + +(defvar exwm-input--skip-buffer-list-update nil + "Skip the upcoming `buffer-list-update'.") + +(defvar exwm-input--temp-line-mode nil + "Non-nil indicates it's in temporary line-mode for `char-mode'.") + +(defvar exwm-input--timestamp-atom nil) + +(defvar exwm-input--timestamp-callback nil) + +(defvar exwm-input--timestamp-window nil) + +(defvar exwm-input--update-focus-timer nil + "Timer for deferring the update of input focus.") + +(defvar exwm-input--update-focus-lock nil + "Lock for solving input focus update contention.") + +(defvar exwm-input--update-focus-window nil "The (Emacs) window to be focused. +This value should always be overwritten.") + +(defvar exwm-input--echo-area-timer nil "Timer for detecting echo area dirty.") + +(defvar exwm-input--event-hook nil + "Hook to run when EXWM receives an event.") + +(defvar exwm-input-input-mode-change-hook nil + "Hook to run when an input mode changes on an `exwm-mode' buffer. +Current buffer will be the `exwm-mode' buffer when this hook runs.") + +(defvar exwm-workspace--current) +(declare-function exwm-floating--do-moveresize "exwm-floating.el" + (data _synthetic)) +(declare-function exwm-floating--start-moveresize "exwm-floating.el" + (id &optional type)) +(declare-function exwm-floating--stop-moveresize "exwm-floating.el" + (&rest _args)) +(declare-function exwm-layout--iconic-state-p "exwm-layout.el" (&optional id)) +(declare-function exwm-layout--show "exwm-layout.el" (id &optional window)) +(declare-function exwm-reset "exwm.el" ()) +(declare-function exwm-workspace--minibuffer-own-frame-p "exwm-workspace.el") +(declare-function exwm-workspace--workspace-p "exwm-workspace.el" (workspace)) +(declare-function exwm-workspace-switch "exwm-workspace.el" + (frame-or-index &optional force)) + +(defun exwm-input--set-focus (id) + "Set input focus to window ID in a proper way." + (let ((from (slot-value (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetInputFocus)) + 'focus)) + tree) + (if (or (exwm--id->buffer from) + (eq from id)) + (exwm--log "#x%x => #x%x" (or from 0) (or id 0)) + ;; Attempt to find the top-level X window for a 'focus proxy'. + (unless (= from xcb:Window:None) + (setq tree (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:QueryTree + :window from))) + (when tree + (setq from (slot-value tree 'parent)))) + (exwm--log "#x%x (corrected) => #x%x" (or from 0) (or id 0))) + (when (and (exwm--id->buffer id) + ;; Avoid redundant input focus transfer. + (not (eq from id))) + (with-current-buffer (exwm--id->buffer id) + (exwm-input--update-timestamp + (lambda (timestamp id send-input-focus wm-take-focus) + (when send-input-focus + (xcb:+request exwm--connection + (make-instance 'xcb:SetInputFocus + :revert-to xcb:InputFocus:Parent + :focus id + :time timestamp))) + (when wm-take-focus + (let ((event (make-instance 'xcb:icccm:WM_TAKE_FOCUS + :window id + :time timestamp))) + (setq event (xcb:marshal event exwm--connection)) + (xcb:+request exwm--connection + (make-instance 'xcb:icccm:SendEvent + :destination id + :event event)))) + (exwm-input--set-active-window id) + (xcb:flush exwm--connection)) + id + (or exwm--hints-input + (not (memq xcb:Atom:WM_TAKE_FOCUS exwm--protocols))) + (memq xcb:Atom:WM_TAKE_FOCUS exwm--protocols)))))) + +(defun exwm-input--update-timestamp (callback &rest args) + "Fetch the latest timestamp from the server and feed it to CALLBACK. + +ARGS are additional arguments to CALLBACK." + (setq exwm-input--timestamp-callback (cons callback args)) + (exwm--log) + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeProperty + :mode xcb:PropMode:Replace + :window exwm-input--timestamp-window + :property exwm-input--timestamp-atom + :type xcb:Atom:CARDINAL + :format 32 + :data-len 0 + :data nil)) + (xcb:flush exwm--connection)) + +(defun exwm-input--on-PropertyNotify (data _synthetic) + "Handle PropertyNotify events." + (exwm--log) + (when exwm-input--timestamp-callback + (let ((obj (make-instance 'xcb:PropertyNotify))) + (xcb:unmarshal obj data) + (when (= exwm-input--timestamp-window + (slot-value obj 'window)) + (apply (car exwm-input--timestamp-callback) + (slot-value obj 'time) + (cdr exwm-input--timestamp-callback)) + (setq exwm-input--timestamp-callback nil))))) + +(defvar exwm-input--last-enter-notify-position nil) + +(defun exwm-input--on-EnterNotify (data _synthetic) + "Handle EnterNotify events." + (let ((evt (make-instance 'xcb:EnterNotify)) + buffer window frame frame-xid edges fake-evt) + (xcb:unmarshal evt data) + (with-slots (time root event root-x root-y event-x event-y state) evt + (setq buffer (exwm--id->buffer event) + window (get-buffer-window buffer t)) + (exwm--log "buffer=%s; window=%s" buffer window) + (when (and buffer window (not (eq window (selected-window))) + (not (equal exwm-input--last-enter-notify-position + (vector root-x root-y)))) + (setq frame (window-frame window) + frame-xid (frame-parameter frame 'exwm-id)) + (unless (eq frame exwm-workspace--current) + (if (exwm-workspace--workspace-p frame) + ;; The X window is on another workspace. + (exwm-workspace-switch frame) + (with-current-buffer buffer + (when (and (derived-mode-p 'exwm-mode) + (not (eq exwm--frame exwm-workspace--current))) + ;; The floating X window is on another workspace. + (exwm-workspace-switch exwm--frame))))) + ;; Send a fake MotionNotify event to Emacs. + (setq edges (window-inside-pixel-edges window) + fake-evt (make-instance 'xcb:MotionNotify + :detail 0 + :time time + :root root + :event frame-xid + :child xcb:Window:None + :root-x root-x + :root-y root-y + :event-x (+ event-x (elt edges 0)) + :event-y (+ event-y (elt edges 1)) + :state state + :same-screen 1)) + (xcb:+request exwm--connection + (make-instance 'xcb:SendEvent + :propagate 0 + :destination frame-xid + :event-mask xcb:EventMask:NoEvent + :event (xcb:marshal fake-evt exwm--connection))) + (xcb:flush exwm--connection)) + (setq exwm-input--last-enter-notify-position (vector root-x root-y))))) + +(defun exwm-input--on-keysyms-update () + (exwm--log) + (let ((exwm-input--global-prefix-keys nil)) + (exwm-input--update-global-prefix-keys))) + +(defun exwm-input--on-buffer-list-update () + "Run in `buffer-list-update-hook' to track input focus." + (when (and ; this hook is called incesantly; place cheap tests on top + (not exwm-input--skip-buffer-list-update) + (exwm--terminal-p) ; skip other terminals, e.g. TTY client frames + (not (frame-parameter nil 'no-accept-focus))) + (exwm--log "current-buffer=%S selected-window=%S" + (current-buffer) (selected-window)) + (redirect-frame-focus (selected-frame) nil) + (setq exwm-input--update-focus-window (selected-window)) + (exwm-input--update-focus-defer))) + +(defun exwm-input--update-focus-defer () + "Schedule a deferred update to input focus. +Instead of immediately focusing the current window, it defers the focus change +until the selected window stops changing (debouncing input focus updates)." + (when exwm-input--update-focus-timer + (cancel-timer exwm-input--update-focus-timer)) + (setq exwm-input--update-focus-timer + ;; Attempt to accumulate successive events close enough. + (run-with-timer exwm-input--update-focus-interval + nil + #'exwm-input--update-focus-commit))) + +(defun exwm-input--update-focus-commit () + "Attempt to update the window focus. +If we're currently updating the window focus, re-schedule a focus update +attempt later." + (if exwm-input--update-focus-lock + (exwm-input--update-focus-defer) + (let ((exwm-input--update-focus-lock t)) + (exwm-input--update-focus exwm-input--update-focus-window)))) + +(defun exwm-input--update-focus (window) + "Update input focus to WINDOW." + (when (window-live-p window) + (exwm--log "focus-window=%s focus-buffer=%s" window (window-buffer window)) + (with-current-buffer (window-buffer window) + (if (derived-mode-p 'exwm-mode) + (if (not (eq exwm--frame exwm-workspace--current)) + (progn + (set-frame-parameter exwm--frame 'exwm-selected-window window) + (exwm--defer 0 #'exwm-workspace-switch exwm--frame)) + (exwm--log "Set focus on #x%x" exwm--id) + (when exwm--floating-frame + ;; Adjust stacking orders of the floating X window. + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window exwm--id + :value-mask xcb:ConfigWindow:StackMode + :stack-mode xcb:StackMode:TopIf)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm--floating-frame + 'exwm-container) + :value-mask (logior + xcb:ConfigWindow:Sibling + xcb:ConfigWindow:StackMode) + :sibling exwm--id + :stack-mode xcb:StackMode:Below)) + ;; This floating X window might be hide by `exwm-floating-hide'. + (when (exwm-layout--iconic-state-p) + (exwm-layout--show exwm--id window)) + (xcb:flush exwm--connection)) + (exwm-input--set-focus exwm--id)) + (when (eq (selected-window) window) + (exwm--log "Focus on %s" window) + (if (and (exwm-workspace--workspace-p (selected-frame)) + (not (eq (selected-frame) exwm-workspace--current))) + ;; The focus is on another workspace (e.g. it got clicked) + ;; so switch to it. + (progn + (exwm--log "Switching to %s's workspace %s (%s)" + window + (window-frame window) + (selected-frame)) + (set-frame-parameter (selected-frame) 'exwm-selected-window + window) + (exwm--defer 0 #'exwm-workspace-switch (selected-frame))) + ;; The focus is still on the current workspace. + (if (not (and (exwm-workspace--minibuffer-own-frame-p) + (minibufferp))) + (x-focus-frame (window-frame window)) + ;; X input focus should be set on the previously selected + ;; frame. + (x-focus-frame (window-frame (minibuffer-window)))) + (exwm-input--set-active-window) + (xcb:flush exwm--connection))))))) + +(defun exwm-input--set-active-window (&optional id) + "Set _NET_ACTIVE_WINDOW." + (exwm--log) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_ACTIVE_WINDOW + :window exwm--root + :data (or id xcb:Window:None)))) + +(defun exwm-input--on-ButtonPress (data _synthetic) + "Handle ButtonPress event." + (let ((obj (make-instance 'xcb:ButtonPress)) + (mode xcb:Allow:SyncPointer) + button-event window buffer frame fake-last-command) + (xcb:unmarshal obj data) + (exwm--log "major-mode=%s buffer=%s" + major-mode (buffer-name (current-buffer))) + (with-slots (detail event state) obj + (setq button-event (xcb:keysyms:keysym->event exwm--connection + detail state) + buffer (exwm--id->buffer event) + window (get-buffer-window buffer t)) + (cond ((and (eq button-event exwm-input-move-event) + buffer + ;; Either an undecorated or a floating X window. + (with-current-buffer buffer + (or (not (derived-mode-p 'exwm-mode)) + exwm--floating-frame))) + ;; Move + (exwm-floating--start-moveresize + event xcb:ewmh:_NET_WM_MOVERESIZE_MOVE)) + ((and (eq button-event exwm-input-resize-event) + buffer + (with-current-buffer buffer + (or (not (derived-mode-p 'exwm-mode)) + exwm--floating-frame))) + ;; Resize + (exwm-floating--start-moveresize event)) + (buffer + ;; Click to focus + (setq fake-last-command t) + (unless (eq window (selected-window)) + (setq frame (window-frame window)) + (unless (eq frame exwm-workspace--current) + (if (exwm-workspace--workspace-p frame) + ;; The X window is on another workspace + (exwm-workspace-switch frame) + (with-current-buffer buffer + (when (and (derived-mode-p 'exwm-mode) + (not (eq exwm--frame + exwm-workspace--current))) + ;; The floating X window is on another workspace + (exwm-workspace-switch exwm--frame))))) + ;; It has been reported that the `window' may have be deleted + (if (window-live-p window) + (select-window window) + (setq window (get-buffer-window buffer t)) + (when window (select-window window)))) + ;; Also process keybindings. + (with-current-buffer buffer + (when (derived-mode-p 'exwm-mode) + (cl-case exwm--input-mode + (line-mode + (setq mode (exwm-input--on-ButtonPress-line-mode + buffer button-event))) + (char-mode + (setq mode (exwm-input--on-ButtonPress-char-mode))))))) + (t + ;; Replay this event by default. + (setq fake-last-command t) + (setq mode xcb:Allow:ReplayPointer))) + (when fake-last-command + (if buffer + (with-current-buffer buffer + (exwm-input--fake-last-command)) + (exwm-input--fake-last-command)))) + (xcb:+request exwm--connection + (make-instance 'xcb:AllowEvents :mode mode :time xcb:Time:CurrentTime)) + (xcb:flush exwm--connection)) + (run-hooks 'exwm-input--event-hook)) + +(defun exwm-input--on-KeyPress (data _synthetic) + "Handle KeyPress event." + (with-current-buffer (window-buffer (selected-window)) + (let ((obj (make-instance 'xcb:KeyPress))) + (xcb:unmarshal obj data) + (exwm--log "major-mode=%s buffer=%s" + major-mode (buffer-name (current-buffer))) + (if (derived-mode-p 'exwm-mode) + (cl-case exwm--input-mode + (line-mode + (exwm-input--on-KeyPress-line-mode obj data)) + (char-mode + (exwm-input--on-KeyPress-char-mode obj data))) + (exwm-input--on-KeyPress-char-mode obj))) + (run-hooks 'exwm-input--event-hook))) + +(defun exwm-input--on-CreateNotify (data _synthetic) + "Handle CreateNotify events." + (exwm--log) + (let ((evt (make-instance 'xcb:CreateNotify))) + (xcb:unmarshal evt data) + (with-slots (window) evt + (exwm-input--grab-global-prefix-keys window)))) + +(defun exwm-input--update-global-prefix-keys () + "Update `exwm-input--global-prefix-keys'." + (exwm--log) + (when exwm--connection + (let ((original exwm-input--global-prefix-keys)) + (setq exwm-input--global-prefix-keys nil) + (dolist (i exwm-input--global-keys) + (cl-pushnew (elt i 0) exwm-input--global-prefix-keys)) + (unless (equal original exwm-input--global-prefix-keys) + (apply #'exwm-input--grab-global-prefix-keys + (slot-value (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:QueryTree + :window exwm--root)) + 'children)))))) + +(defun exwm-input--grab-global-prefix-keys (&rest xwins) + (exwm--log) + (let ((req (make-instance 'xcb:GrabKey + :owner-events 0 + :grab-window nil + :modifiers nil + :key nil + :pointer-mode xcb:GrabMode:Async + :keyboard-mode xcb:GrabMode:Async)) + keysyms keycode alt-modifier) + (dolist (k exwm-input--global-prefix-keys) + (setq keysyms (xcb:keysyms:event->keysyms exwm--connection k)) + (if (not keysyms) + (warn "Key unavailable: %s" (key-description (vector k))) + (setq keycode (xcb:keysyms:keysym->keycode exwm--connection + (caar keysyms))) + (exwm--log "Grabbing key=%s (keysyms=%s keycode=%s)" + (single-key-description k) keysyms keycode) + (dolist (keysym keysyms) + (setf (slot-value req 'modifiers) (cdr keysym) + (slot-value req 'key) keycode) + ;; Also grab this key with num-lock mask set. + (when (and (/= 0 xcb:keysyms:num-lock-mask) + (= 0 (logand (cdr keysym) xcb:keysyms:num-lock-mask))) + (setf alt-modifier (logior (cdr keysym) + xcb:keysyms:num-lock-mask))) + (dolist (xwin xwins) + (setf (slot-value req 'grab-window) xwin) + (xcb:+request exwm--connection req) + (when alt-modifier + (setf (slot-value req 'modifiers) alt-modifier) + (xcb:+request exwm--connection req)))))) + (xcb:flush exwm--connection))) + +(defun exwm-input--set-key (key command) + (exwm--log "key: %s, command: %s" key command) + (global-set-key key command) + (cl-pushnew key exwm-input--global-keys)) + +(defcustom exwm-input-global-keys nil + "Global keys. + +It is an alist of the form (key . command), meaning giving KEY (a key +sequence) a global binding as COMMAND. + +Notes: +* Setting the value directly (rather than customizing it) after EXWM + finishes initialization has no effect." + :type '(alist :key-type key-sequence :value-type function) + :set (lambda (symbol value) + (when (boundp symbol) + (dolist (i (symbol-value symbol)) + (global-unset-key (car i)))) + (set symbol value) + (setq exwm-input--global-keys nil) + (dolist (i value) + (exwm-input--set-key (car i) (cdr i))) + (when exwm--connection + (exwm-input--update-global-prefix-keys)))) + +;;;###autoload +(defun exwm-input-set-key (key command) + "Set a global key binding. + +The new key binding only takes effect in real time when this command is +called interactively, and is lost when this session ends unless it's +specifically saved in the Customize interface for `exwm-input-global-keys'. + +In configuration you should customize or set `exwm-input-global-keys' +instead." + (interactive "KSet key globally: \nCSet key %s to command: ") + (exwm--log) + (setq exwm-input-global-keys (append exwm-input-global-keys + (list (cons key command)))) + (exwm-input--set-key key command) + (when (called-interactively-p 'any) + (exwm-input--update-global-prefix-keys))) + +(defsubst exwm-input--unread-event (event) + (declare (indent defun)) + (setq unread-command-events + (append unread-command-events `((t . ,event))))) + +(defun exwm-input--mimic-read-event (event) + "Process EVENT as if it were returned by `read-event'." + (exwm--log) + (unless (eq 0 extra-keyboard-modifiers) + (setq event (event-convert-list (append (event-modifiers + extra-keyboard-modifiers) + event)))) + (when (characterp event) + (let ((event* (when keyboard-translate-table + (aref keyboard-translate-table event)))) + (when event* + (setq event event*)))) + event) + +(cl-defun exwm-input--translate (key) + (let (translation) + (dolist (map (list input-decode-map + local-function-key-map + key-translation-map)) + (setq translation (lookup-key map key)) + (if (functionp translation) + (cl-return-from exwm-input--translate (funcall translation nil)) + (when (vectorp translation) + (cl-return-from exwm-input--translate translation))))) + key) + +(defun exwm-input--cache-event (event &optional temp-line-mode) + "Cache EVENT." + (exwm--log "%s" event) + (setq exwm-input--line-mode-cache + (vconcat exwm-input--line-mode-cache (vector event))) + ;; Attempt to translate this key sequence. + (setq exwm-input--line-mode-cache + (exwm-input--translate exwm-input--line-mode-cache)) + ;; When the key sequence is complete (not a keymap). + ;; Note that `exwm-input--line-mode-cache' might get translated to nil, for + ;; example 'mouse--down-1-maybe-follows-link' does this. + (if (and exwm-input--line-mode-cache + (keymapp (key-binding exwm-input--line-mode-cache))) + ;; Grab keyboard temporarily to intercept the complete key sequence. + (when temp-line-mode + (setq exwm-input--temp-line-mode t) + (exwm-input--grab-keyboard)) + (setq exwm-input--line-mode-cache nil) + (when exwm-input--temp-line-mode + (setq exwm-input--temp-line-mode nil) + (exwm-input--release-keyboard)))) + +(defun exwm-input--event-passthrough-p (event) + "Whether EVENT should be passed to Emacs. +Current buffer must be an `exwm-mode' buffer." + (or exwm-input-line-mode-passthrough + exwm-input--during-command + ;; Forward the event when there is an incomplete key + ;; sequence or when the minibuffer is active. + exwm-input--line-mode-cache + (eq (active-minibuffer-window) (selected-window)) + ;; + (memq event exwm-input--global-prefix-keys) + (memq event exwm-input-prefix-keys) + (when overriding-terminal-local-map + (lookup-key overriding-terminal-local-map + (vector event))) + (lookup-key (current-local-map) (vector event)) + (gethash event exwm-input--simulation-keys))) + +(defun exwm-input--noop (&rest _args) + "A placeholder command." + (interactive)) + +(defun exwm-input--fake-last-command () + "Fool some packages into thinking there is a change in the buffer." + (setq last-command #'exwm-input--noop) + ;; The Emacs manual says: + ;; > Quitting is suppressed while running pre-command-hook and + ;; > post-command-hook. If an error happens while executing one of these + ;; > hooks, it does not terminate execution of the hook; instead the error is + ;; > silenced and the function in which the error occurred is removed from the + ;; > hook. + ;; We supress errors but neither continue execution nor we remove from the + ;; hook. + (condition-case err + (run-hooks 'pre-command-hook) + ((error) + (exwm--log "Error occurred while running pre-command-hook: %s" + (error-message-string err)) + (xcb-debug:backtrace))) + (condition-case err + (run-hooks 'post-command-hook) + ((error) + (exwm--log "Error occurred while running post-command-hook: %s" + (error-message-string err)) + (xcb-debug:backtrace)))) + +(defun exwm-input--on-KeyPress-line-mode (key-press raw-data) + "Parse X KeyPress event to Emacs key event and then feed the command loop." + (with-slots (detail state) key-press + (let ((keysym (xcb:keysyms:keycode->keysym exwm--connection detail state)) + event raw-event mode) + (exwm--log "%s" keysym) + (when (and (/= 0 (car keysym)) + (setq raw-event (xcb:keysyms:keysym->event + exwm--connection (car keysym) + (logand state (lognot (cdr keysym))))) + (setq event (exwm-input--mimic-read-event raw-event)) + (exwm-input--event-passthrough-p event)) + (setq mode xcb:Allow:AsyncKeyboard) + (exwm-input--cache-event event) + (exwm-input--unread-event raw-event)) + (unless mode + (if (= 0 (logand #x6000 state)) ;Check the 13~14 bits. + ;; Not an XKB state; just replay it. + (setq mode xcb:Allow:ReplayKeyboard) + ;; An XKB state; sent it with SendEvent. + ;; FIXME: Can this also be replayed? + ;; FIXME: KeyRelease events are lost. + (setq mode xcb:Allow:AsyncKeyboard) + (xcb:+request exwm--connection + (make-instance 'xcb:SendEvent + :propagate 0 + :destination (slot-value key-press 'event) + :event-mask xcb:EventMask:NoEvent + :event raw-data))) + (when event + (if (not defining-kbd-macro) + (exwm-input--fake-last-command) + ;; Make Emacs aware of this event when defining keyboard macros. + (set-transient-map `(keymap (t . ,#'exwm-input--noop))) + (exwm-input--unread-event event)))) + (xcb:+request exwm--connection + (make-instance 'xcb:AllowEvents + :mode mode + :time xcb:Time:CurrentTime)) + (xcb:flush exwm--connection)))) + +(defun exwm-input--on-KeyPress-char-mode (key-press &optional _raw-data) + "Handle KeyPress event in `char-mode'." + (with-slots (detail state) key-press + (let ((keysym (xcb:keysyms:keycode->keysym exwm--connection detail state)) + event raw-event) + (exwm--log "%s" keysym) + (when (and (/= 0 (car keysym)) + (setq raw-event (xcb:keysyms:keysym->event + exwm--connection (car keysym) + (logand state (lognot (cdr keysym))))) + (setq event (exwm-input--mimic-read-event raw-event))) + (if (not (derived-mode-p 'exwm-mode)) + (exwm-input--unread-event raw-event) + (exwm-input--cache-event event t) + (exwm-input--unread-event raw-event))))) + (xcb:+request exwm--connection + (make-instance 'xcb:AllowEvents + :mode xcb:Allow:AsyncKeyboard + :time xcb:Time:CurrentTime)) + (xcb:flush exwm--connection)) + +(defun exwm-input--on-ButtonPress-line-mode (buffer button-event) + "Handle button events in line mode. +BUFFER is the `exwm-mode' buffer the event was generated +on. BUTTON-EVENT is the X event converted into an Emacs event. + +The return value is used as event_mode to release the original +button event." + (with-current-buffer buffer + (let ((read-event (exwm-input--mimic-read-event button-event))) + (exwm--log "%s" read-event) + (if (and read-event + (exwm-input--event-passthrough-p read-event)) + ;; The event should be forwarded to emacs + (progn + (exwm-input--cache-event read-event) + (exwm-input--unread-event button-event) + xcb:Allow:SyncPointer) + ;; The event should be replayed + xcb:Allow:ReplayPointer)))) + +(defun exwm-input--on-ButtonPress-char-mode () + "Handle button events in `char-mode'. +The return value is used as event_mode to release the original +button event." + (exwm--log) + xcb:Allow:ReplayPointer) + +(defun exwm-input--update-mode-line (id) + "Update the propertized `mode-line-process' for window ID." + (exwm--log "#x%x" id) + (let (help-echo cmd mode) + (with-current-buffer (exwm--id->buffer id) + (cl-case exwm--input-mode + (line-mode + (setq mode "line" + help-echo "mouse-1: Switch to char-mode" + cmd (lambda () + (interactive) + (exwm-input-release-keyboard id)))) + (char-mode + (setq mode "char" + help-echo "mouse-1: Switch to line-mode" + cmd (lambda () + (interactive) + (exwm-input-grab-keyboard id))))) + (setq mode-line-process + `(": " + (:propertize ,mode + help-echo ,help-echo + mouse-face mode-line-highlight + local-map + (keymap + (mode-line + keymap + (down-mouse-1 . ,cmd)))))) + (force-mode-line-update)))) + +(defun exwm-input--grab-keyboard (&optional id) + "Grab all key events on window ID." + (unless id (setq id (exwm--buffer->id (window-buffer)))) + (when id + (exwm--log "id=#x%x" id) + (when (xcb:+request-checked+request-check exwm--connection + (make-instance 'xcb:GrabKey + :owner-events 0 + :grab-window id + :modifiers xcb:ModMask:Any + :key xcb:Grab:Any + :pointer-mode xcb:GrabMode:Async + :keyboard-mode xcb:GrabMode:Sync)) + (exwm--log "Failed to grab keyboard for #x%x" id)) + (let ((buffer (exwm--id->buffer id))) + (when buffer + (with-current-buffer buffer + (setq exwm--input-mode 'line-mode) + (run-hooks 'exwm-input-input-mode-change-hook)))))) + +(defun exwm-input--release-keyboard (&optional id) + "Ungrab all key events on window ID." + (unless id (setq id (exwm--buffer->id (window-buffer)))) + (when id + (exwm--log "id=#x%x" id) + (when (xcb:+request-checked+request-check exwm--connection + (make-instance 'xcb:UngrabKey + :key xcb:Grab:Any + :grab-window id + :modifiers xcb:ModMask:Any)) + (exwm--log "Failed to release keyboard for #x%x" id)) + (exwm-input--grab-global-prefix-keys id) + (let ((buffer (exwm--id->buffer id))) + (when buffer + (with-current-buffer buffer + (setq exwm--input-mode 'char-mode) + (run-hooks 'exwm-input-input-mode-change-hook)))))) + +;;;###autoload +(defun exwm-input-grab-keyboard (&optional id) + "Switch to `line-mode'." + (interactive (list (when (derived-mode-p 'exwm-mode) + (exwm--buffer->id (window-buffer))))) + (when id + (exwm--log "id=#x%x" id) + (setq exwm--selected-input-mode 'line-mode) + (exwm-input--grab-keyboard id) + (exwm-input--update-mode-line id))) + +;;;###autoload +(defun exwm-input-release-keyboard (&optional id) + "Switch to `char-mode`." + (interactive (list (when (derived-mode-p 'exwm-mode) + (exwm--buffer->id (window-buffer))))) + (when id + (exwm--log "id=#x%x" id) + (setq exwm--selected-input-mode 'char-mode) + (exwm-input--release-keyboard id) + (exwm-input--update-mode-line id))) + +;;;###autoload +(defun exwm-input-toggle-keyboard (&optional id) + "Toggle between `line-mode' and `char-mode'." + (interactive (list (when (derived-mode-p 'exwm-mode) + (exwm--buffer->id (window-buffer))))) + (when id + (exwm--log "id=#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (cl-case exwm--input-mode + (line-mode + (exwm-input-release-keyboard id)) + (char-mode + (exwm-reset)))))) + +(defun exwm-input--fake-key (event) + "Fake a key event equivalent to Emacs event EVENT." + (let* ((keysyms (xcb:keysyms:event->keysyms exwm--connection event)) + keycode id) + (when (= 0 (caar keysyms)) + (user-error "[EXWM] Invalid key: %s" (single-key-description event))) + (setq keycode (xcb:keysyms:keysym->keycode exwm--connection + (caar keysyms))) + (when (/= 0 keycode) + (setq id (exwm--buffer->id (window-buffer (selected-window)))) + (exwm--log "id=#x%x event=%s keycode" id event keycode) + (dolist (class '(xcb:KeyPress xcb:KeyRelease)) + (xcb:+request exwm--connection + (make-instance 'xcb:SendEvent + :propagate 0 :destination id + :event-mask xcb:EventMask:NoEvent + :event (xcb:marshal + (make-instance class + :detail keycode + :time xcb:Time:CurrentTime + :root exwm--root :event id + :child 0 + :root-x 0 :root-y 0 + :event-x 0 :event-y 0 + :state (cdar keysyms) + :same-screen 1) + exwm--connection))))) + (xcb:flush exwm--connection))) + +;;;###autoload +(cl-defun exwm-input-send-next-key (times &optional end-key) + "Send next key to client window. + +EXWM will prompt for the key to send. This command can be prefixed to send +multiple keys. If END-KEY is non-nil, stop sending keys if it's pressed." + (interactive "p") + (exwm--log) + (unless (derived-mode-p 'exwm-mode) + (cl-return-from exwm-input-send-next-key)) + (when (> times 12) (setq times 12)) + (let (key keys) + (dotimes (i times) + ;; Skip events not from keyboard + (let ((exwm-input-line-mode-passthrough t)) + (catch 'break + (while t + (setq key (read-key (format "Send key: %s (%d/%d) %s" + (key-description keys) + (1+ i) times + (if end-key + (concat "To exit, press: " + (key-description + (list end-key))) + "")))) + (unless (listp key) (throw 'break nil))))) + (setq keys (vconcat keys (vector key))) + (when (eq key end-key) (cl-return-from exwm-input-send-next-key)) + (exwm-input--fake-key key)))) + +(defun exwm-input--set-simulation-keys (simulation-keys &optional no-refresh) + "Set simulation keys." + (exwm--log "%s" simulation-keys) + (unless no-refresh + ;; Unbind simulation keys. + (let ((hash (buffer-local-value 'exwm-input--simulation-keys + (current-buffer)))) + (when (hash-table-p hash) + (maphash (lambda (key _value) + (when (sequencep key) + (if exwm-input--local-simulation-keys + (local-unset-key key) + (define-key exwm-mode-map key nil)))) + hash))) + ;; Abandon the old hash table. + (setq exwm-input--simulation-keys (make-hash-table :test #'equal))) + (dolist (i simulation-keys) + (let ((original (vconcat (car i))) + (simulated (cdr i))) + (setq simulated (if (sequencep simulated) + (append simulated nil) + (list simulated))) + ;; The key stored is a key sequence (vector). + ;; The value stored is a list of key events. + (puthash original simulated exwm-input--simulation-keys) + ;; Also mark the prefix key as used. + (puthash (aref original 0) t exwm-input--simulation-keys))) + ;; Update keymaps. + (maphash (lambda (key _value) + (when (sequencep key) + (if exwm-input--local-simulation-keys + (local-set-key key #'exwm-input-send-simulation-key) + (define-key exwm-mode-map key + #'exwm-input-send-simulation-key)))) + exwm-input--simulation-keys)) + +(defcustom exwm-input-simulation-keys nil + "Simulation keys. + +It is an alist of the form (original-key . simulated-key), where both +original-key and simulated-key are key sequences. Original-key is what you +type to an X window in `line-mode' which then gets translated to simulated-key +by EXWM and forwarded to the X window. + +Notes: +* Setting the value directly (rather than customizing it) after EXWM + finishes initialization has no effect. +* Original-keys consist of multiple key events are only supported in Emacs + 26.2 and later. +* A minority of applications do not accept simulated keys by default. It's + required to customize them to accept events sent by SendEvent. +* The predefined examples in the Customize interface are not guaranteed to + work for all applications. This can be tweaked on a per application basis + with `exwm-input-set-local-simulation-keys'." + :type '(alist :key-type (key-sequence :tag "Original") + :value-type (choice (key-sequence :tag "User-defined") + (key-sequence :tag "Move left" [left]) + (key-sequence :tag "Move right" [right]) + (key-sequence :tag "Move up" [up]) + (key-sequence :tag "Move down" [down]) + (key-sequence :tag "Move to BOL" [home]) + (key-sequence :tag "Move to EOL" [end]) + (key-sequence :tag "Page up" [prior]) + (key-sequence :tag "Page down" [next]) + (key-sequence :tag "Copy" [C-c]) + (key-sequence :tag "Paste" [C-v]) + (key-sequence :tag "Delete" [delete]) + (key-sequence :tag "Delete to EOL" + [S-end delete]))) + :set (lambda (symbol value) + (set symbol value) + (exwm-input--set-simulation-keys value))) + +(defcustom exwm-input-pre-post-command-blacklist '(exit-minibuffer + abort-recursive-edit + minibuffer-keyboard-quit) + "Commands impossible to detect with `post-command-hook'." + :type '(repeat function)) + +(cl-defun exwm-input--read-keys (prompt stop-key) + (let ((cursor-in-echo-area t) + keys key) + (while (not (eq key stop-key)) + (setq key (read-key (format "%s (terminate with %s): %s" + prompt + (key-description (vector stop-key)) + (key-description keys))) + keys (vconcat keys (vector key)))) + (when (> (length keys) 1) + (substring keys 0 -1)))) + +;;;###autoload +(defun exwm-input-set-simulation-key (original-key simulated-key) + "Set a simulation key. + +The simulation key takes effect in real time, but is lost when this session +ends unless it's specifically saved in the Customize interface for +`exwm-input-simulation-keys'." + (interactive + (let (original simulated) + (setq original (exwm-input--read-keys "Translate from" ?\C-g)) + (when original + (setq simulated (exwm-input--read-keys + (format "Translate from %s to" + (key-description original)) + ?\C-g))) + (list original simulated))) + (exwm--log "original: %s, simulated: %s" original-key simulated-key) + (when (and original-key simulated-key) + (let ((entry `((,original-key . ,simulated-key)))) + (setq exwm-input-simulation-keys (append exwm-input-simulation-keys + entry)) + (exwm-input--set-simulation-keys entry t)))) + +(defun exwm-input--unset-simulation-keys () + "Clear simulation keys and key bindings defined." + (exwm--log) + (when (hash-table-p exwm-input--simulation-keys) + (maphash (lambda (key _value) + (when (sequencep key) + (define-key exwm-mode-map key nil))) + exwm-input--simulation-keys) + (clrhash exwm-input--simulation-keys))) + +(defun exwm-input-set-local-simulation-keys (simulation-keys) + "Set buffer-local simulation keys. + +SIMULATION-KEYS is an alist of the form (original-key . simulated-key), +where both ORIGINAL-KEY and SIMULATED-KEY are key sequences." + (exwm--log) + (make-local-variable 'exwm-input--simulation-keys) + (use-local-map (copy-keymap exwm-mode-map)) + (let ((exwm-input--local-simulation-keys t)) + (exwm-input--set-simulation-keys simulation-keys))) + +;;;###autoload +(cl-defun exwm-input-send-simulation-key (times) + "Fake a key event according to the last input key sequence." + (interactive "p") + (exwm--log) + (unless (derived-mode-p 'exwm-mode) + (cl-return-from exwm-input-send-simulation-key)) + (let ((keys (gethash (this-single-command-keys) + exwm-input--simulation-keys))) + (dotimes (_ times) + (dolist (key keys) + (exwm-input--fake-key key))))) + +;;;###autoload +(defmacro exwm-input-invoke-factory (keys) + "Make a command that invokes KEYS when called. + +One use is to access the keymap bound to KEYS (as prefix keys) in `char-mode'." + (let* ((keys (kbd keys)) + (description (key-description keys))) + `(defun ,(intern (concat "exwm-input--invoke--" description)) () + ,(format "Invoke `%s'." description) + (interactive) + (mapc (lambda (key) + (exwm-input--cache-event key t) + (exwm-input--unread-event key)) + ',(listify-key-sequence keys))))) + +(defun exwm-input--on-pre-command () + "Run in `pre-command-hook'." + (unless (or (eq this-command #'exwm-input--noop) + (memq this-command exwm-input-pre-post-command-blacklist)) + (setq exwm-input--during-command t))) + +(defun exwm-input--on-post-command () + "Run in `post-command-hook'." + (unless (eq this-command #'exwm-input--noop) + (setq exwm-input--during-command nil))) + +(defun exwm-input--on-minibuffer-setup () + "Run in `minibuffer-setup-hook' to grab keyboard if necessary." + (let* ((window (or (minibuffer-selected-window) ; minibuffer-setup-hook + (selected-window))) ; echo-area-clear-hook + (frame (window-frame window))) + (when (exwm--terminal-p frame) + (with-current-buffer (window-buffer window) + (when (and (derived-mode-p 'exwm-mode) + (eq exwm--selected-input-mode 'char-mode)) + (exwm--log "Grab #x%x window=%s frame=%s" exwm--id window frame) + (exwm-input--grab-keyboard exwm--id)))))) + +(defun exwm-input--on-minibuffer-exit () + "Run in `minibuffer-exit-hook' to release keyboard if necessary." + (let* ((window (or (minibuffer-selected-window) ; minibuffer-setup-hook + (selected-window))) ; echo-area-clear-hook + (frame (window-frame window))) + (when (exwm--terminal-p frame) + (with-current-buffer (window-buffer window) + (when (and (derived-mode-p 'exwm-mode) + (eq exwm--selected-input-mode 'char-mode) + (eq exwm--input-mode 'line-mode)) + (exwm--log "Release #x%x window=%s frame=%s" exwm--id window frame) + (exwm-input--release-keyboard exwm--id)))))) + +(defun exwm-input--on-echo-area-dirty () + "Run when new message arrives to grab keyboard if necessary." + (when (and cursor-in-echo-area + (not (active-minibuffer-window))) + (exwm--log) + (exwm-input--on-minibuffer-setup))) + +(defun exwm-input--on-echo-area-clear () + "Run in `echo-area-clear-hook' to release keyboard if necessary." + (unless (current-message) + (exwm--log) + (exwm-input--on-minibuffer-exit))) + +(defun exwm-input--call-with-passthrough (function &rest args) + "Bind `exwm-input-line-mode-passthrough' and call FUNCTION with ARGS." + (let ((exwm-input-line-mode-passthrough t)) + (apply function args))) + +(defun exwm-input--init () + "Initialize the keyboard module." + (exwm--log) + ;; Refresh keyboard mapping + (xcb:keysyms:init exwm--connection #'exwm-input--on-keysyms-update) + ;; Create the X window and intern the atom used to fetch timestamp. + (setq exwm-input--timestamp-window (xcb:generate-id exwm--connection)) + (xcb:+request exwm--connection + (make-instance 'xcb:CreateWindow + :depth 0 + :wid exwm-input--timestamp-window + :parent exwm--root + :x -1 + :y -1 + :width 1 + :height 1 + :border-width 0 + :class xcb:WindowClass:CopyFromParent + :visual 0 + :value-mask xcb:CW:EventMask + :event-mask xcb:EventMask:PropertyChange)) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window exwm-input--timestamp-window + :data "EXWM: exwm-input--timestamp-window")) + (setq exwm-input--timestamp-atom (exwm--intern-atom "_TIME")) + ;; Initialize global keys. + (dolist (i exwm-input-global-keys) + (exwm-input--set-key (car i) (cdr i))) + ;; Initialize simulation keys. + (when exwm-input-simulation-keys + (exwm-input--set-simulation-keys exwm-input-simulation-keys)) + ;; Attach event listeners + (xcb:+event exwm--connection 'xcb:PropertyNotify + #'exwm-input--on-PropertyNotify) + (xcb:+event exwm--connection 'xcb:CreateNotify #'exwm-input--on-CreateNotify) + (xcb:+event exwm--connection 'xcb:KeyPress #'exwm-input--on-KeyPress) + (xcb:+event exwm--connection 'xcb:ButtonPress #'exwm-input--on-ButtonPress) + (xcb:+event exwm--connection 'xcb:ButtonRelease + #'exwm-floating--stop-moveresize) + (xcb:+event exwm--connection 'xcb:MotionNotify + #'exwm-floating--do-moveresize) + (when mouse-autoselect-window + (xcb:+event exwm--connection 'xcb:EnterNotify + #'exwm-input--on-EnterNotify)) + ;; Control `exwm-input--during-command' + (add-hook 'pre-command-hook #'exwm-input--on-pre-command) + (add-hook 'post-command-hook #'exwm-input--on-post-command) + ;; Grab/Release keyboard when minibuffer/echo becomes active/inactive. + (add-hook 'minibuffer-setup-hook #'exwm-input--on-minibuffer-setup) + (add-hook 'minibuffer-exit-hook #'exwm-input--on-minibuffer-exit) + (setq exwm-input--echo-area-timer + (run-with-idle-timer 0 t #'exwm-input--on-echo-area-dirty)) + (add-hook 'echo-area-clear-hook #'exwm-input--on-echo-area-clear) + ;; Update focus when buffer list updates + (add-hook 'buffer-list-update-hook #'exwm-input--on-buffer-list-update) + + (dolist (fun exwm-input--passthrough-functions) + (advice-add fun :around #'exwm-input--call-with-passthrough))) + +(defun exwm-input--post-init () + "The second stage in the initialization of the input module." + (exwm--log) + (exwm-input--update-global-prefix-keys)) + +(defun exwm-input--exit () + "Exit the input module." + (exwm--log) + (dolist (fun exwm-input--passthrough-functions) + (advice-remove fun #'exwm-input--call-with-passthrough)) + (exwm-input--unset-simulation-keys) + (remove-hook 'pre-command-hook #'exwm-input--on-pre-command) + (remove-hook 'post-command-hook #'exwm-input--on-post-command) + (remove-hook 'minibuffer-setup-hook #'exwm-input--on-minibuffer-setup) + (remove-hook 'minibuffer-exit-hook #'exwm-input--on-minibuffer-exit) + (when exwm-input--echo-area-timer + (cancel-timer exwm-input--echo-area-timer) + (setq exwm-input--echo-area-timer nil)) + (remove-hook 'echo-area-clear-hook #'exwm-input--on-echo-area-clear) + (remove-hook 'buffer-list-update-hook #'exwm-input--on-buffer-list-update) + (when exwm-input--update-focus-timer + (cancel-timer exwm-input--update-focus-timer)) + ;; Make input focus working even without a WM. + (when (slot-value exwm--connection 'connected) + (xcb:+request exwm--connection + (make-instance 'xcb:SetInputFocus + :revert-to xcb:InputFocus:PointerRoot + :focus exwm--root + :time xcb:Time:CurrentTime)) + (xcb:flush exwm--connection))) + + + +(provide 'exwm-input) + +;;; exwm-input.el ends here diff --git a/third_party/exwm/exwm-layout.el b/third_party/exwm/exwm-layout.el new file mode 100644 index 0000000000..8649c11ffd --- /dev/null +++ b/third_party/exwm/exwm-layout.el @@ -0,0 +1,631 @@ +;;; exwm-layout.el --- Layout Module for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2024 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module is responsible for keeping X client window properly displayed. + +;;; Code: + +(require 'exwm-core) + +(defgroup exwm-layout nil + "Layout." + :group 'exwm) + +(defcustom exwm-layout-auto-iconify t + "Non-nil to automatically iconify unused X windows when possible." + :type 'boolean) + +(defcustom exwm-layout-show-all-buffers nil + "Non-nil to allow switching to buffers on other workspaces." + :type 'boolean) + +(defconst exwm-layout--floating-hidden-position -101 + "Where to place hidden floating X windows.") + +(defvar exwm-layout--other-buffer-exclude-buffers nil + "List of buffers that should not be selected by `other-buffer'.") + +(defvar exwm-layout--other-buffer-exclude-exwm-mode-buffers nil + "When non-nil, prevent EXWM buffers from being selected by `other-buffer'.") + +(defvar exwm-layout--timer nil "Timer used to track echo area changes.") + +(defvar exwm-workspace--current) +(defvar exwm-workspace--frame-y-offset) +(declare-function exwm-input--release-keyboard "exwm-input.el") +(declare-function exwm-input--grab-keyboard "exwm-input.el") +(declare-function exwm-input-grab-keyboard "exwm-input.el") +(declare-function exwm-workspace--active-p "exwm-workspace.el" (frame)) +(declare-function exwm-workspace--get-geometry "exwm-workspace.el" (frame)) +(declare-function exwm-workspace--minibuffer-own-frame-p "exwm-workspace.el") +(declare-function exwm-workspace--workspace-p "exwm-workspace.el" + (workspace)) +(declare-function exwm-workspace-move-window "exwm-workspace.el" + (frame-or-index &optional id)) + +(defun exwm-layout--set-state (id state) + "Set WM_STATE of X window ID to STATE." + (exwm--log "id=#x%x" id) + (xcb:+request exwm--connection + (make-instance 'xcb:icccm:set-WM_STATE + :window id :state state :icon xcb:Window:None)) + (with-current-buffer (exwm--id->buffer id) + (setq exwm-state state))) + +(defun exwm-layout--iconic-state-p (&optional id) + "Check whether X window ID is in iconic state." + (= xcb:icccm:WM_STATE:IconicState + (if id + (buffer-local-value 'exwm-state (exwm--id->buffer id)) + exwm-state))) + +(defun exwm-layout--set-ewmh-state (id) + "Set _NET_WM_STATE of X window ID to the value of variable `exwm--ewmh-state'." + (with-current-buffer (exwm--id->buffer id) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_STATE + :window exwm--id + :data exwm--ewmh-state)))) + +(defun exwm-layout--fullscreen-p () + "Check whether current `exwm-mode' buffer is in fullscreen state." + (when (derived-mode-p 'exwm-mode) + (memq xcb:Atom:_NET_WM_STATE_FULLSCREEN exwm--ewmh-state))) + +(defun exwm-layout--auto-iconify () + "Helper function to iconify unused X windows. +See variable `exwm-layout-auto-iconify'." + (when (and exwm-layout-auto-iconify + (not exwm-transient-for)) + (let ((xwin exwm--id) + (state exwm-state)) + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (when (and exwm--floating-frame + (eq exwm-transient-for xwin) + (not (eq exwm-state state))) + (if (eq state xcb:icccm:WM_STATE:NormalState) + (exwm-layout--refresh-floating exwm--floating-frame) + (exwm-layout--hide exwm--id)))))))) + +(defun exwm-layout--show (id &optional window) + "Show window ID exactly fit in the Emacs window WINDOW." + (exwm--log "Show #x%x in %s" id window) + (let* ((edges (window-inside-absolute-pixel-edges window)) + (x (pop edges)) + (y (pop edges)) + (width (- (pop edges) x)) + (height (- (pop edges) y)) + frame-x frame-y frame-width frame-height) + (with-current-buffer (exwm--id->buffer id) + (when exwm--floating-frame + (setq frame-width (frame-pixel-width exwm--floating-frame) + frame-height (+ (frame-pixel-height exwm--floating-frame) + ;; Use `frame-outer-height' in the future. + exwm-workspace--frame-y-offset)) + (when exwm--floating-frame-position + (setq frame-x (elt exwm--floating-frame-position 0) + frame-y (elt exwm--floating-frame-position 1) + x (+ x frame-x (- exwm-layout--floating-hidden-position)) + y (+ y frame-y (- exwm-layout--floating-hidden-position))) + (setq exwm--floating-frame-position nil)) + (exwm--set-geometry (frame-parameter exwm--floating-frame + 'exwm-container) + frame-x frame-y frame-width frame-height)) + (when (exwm-layout--fullscreen-p) + (with-slots ((x* x) + (y* y) + (width* width) + (height* height)) + (exwm-workspace--get-geometry exwm--frame) + (setq x x* + y y* + width width* + height height*))) + (exwm--set-geometry id x y width height) + (xcb:+request exwm--connection (make-instance 'xcb:MapWindow :window id)) + (exwm-layout--set-state id xcb:icccm:WM_STATE:NormalState) + (setq exwm--ewmh-state + (delq xcb:Atom:_NET_WM_STATE_HIDDEN exwm--ewmh-state)) + (exwm-layout--set-ewmh-state id) + (exwm-layout--auto-iconify))) + (xcb:flush exwm--connection)) + +(defun exwm-layout--hide (id) + "Hide window ID." + (with-current-buffer (exwm--id->buffer id) + (unless (or (exwm-layout--iconic-state-p) + (and exwm--floating-frame + exwm--desktop + (= 4294967295. exwm--desktop))) + (exwm--log "Hide #x%x" id) + (when exwm--floating-frame + (let* ((container (frame-parameter exwm--floating-frame + 'exwm-container)) + (geometry (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable container)))) + (setq exwm--floating-frame-position + (vector (slot-value geometry 'x) (slot-value geometry 'y))) + (exwm--set-geometry container exwm-layout--floating-hidden-position + exwm-layout--floating-hidden-position + 1 + 1))) + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window id :value-mask xcb:CW:EventMask + :event-mask xcb:EventMask:NoEvent)) + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow :window id)) + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window id :value-mask xcb:CW:EventMask + :event-mask (exwm--get-client-event-mask))) + (exwm-layout--set-state id xcb:icccm:WM_STATE:IconicState) + (cl-pushnew xcb:Atom:_NET_WM_STATE_HIDDEN exwm--ewmh-state) + (exwm-layout--set-ewmh-state id) + (exwm-layout--auto-iconify) + (xcb:flush exwm--connection)))) + +;;;###autoload +(cl-defun exwm-layout-set-fullscreen (&optional id) + "Make window ID fullscreen." + (interactive) + (exwm--log "id=#x%x" (or id 0)) + (unless (and (or id (derived-mode-p 'exwm-mode)) + (not (exwm-layout--fullscreen-p))) + (cl-return-from exwm-layout-set-fullscreen)) + (with-current-buffer (if id (exwm--id->buffer id) (window-buffer)) + ;; Expand the X window to fill the whole screen. + (with-slots (x y width height) (exwm-workspace--get-geometry exwm--frame) + (exwm--set-geometry exwm--id x y width height)) + ;; Raise the X window. + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window exwm--id + :value-mask (logior xcb:ConfigWindow:BorderWidth + xcb:ConfigWindow:StackMode) + :border-width 0 + :stack-mode xcb:StackMode:Above)) + (cl-pushnew xcb:Atom:_NET_WM_STATE_FULLSCREEN exwm--ewmh-state) + (exwm-layout--set-ewmh-state exwm--id) + (xcb:flush exwm--connection) + (set-window-dedicated-p (get-buffer-window) t) + (exwm-input--release-keyboard exwm--id))) + +;;;###autoload +(cl-defun exwm-layout-unset-fullscreen (&optional id) + "Restore X window ID from fullscreen state." + (interactive) + (exwm--log "id=#x%x" (or id 0)) + (unless (and (or id (derived-mode-p 'exwm-mode)) + (exwm-layout--fullscreen-p)) + (cl-return-from exwm-layout-unset-fullscreen)) + (with-current-buffer (if id (exwm--id->buffer id) (window-buffer)) + ;; `exwm-layout--show' relies on `exwm--ewmh-state' to decide whether to + ;; fullscreen the window. + (setq exwm--ewmh-state + (delq xcb:Atom:_NET_WM_STATE_FULLSCREEN exwm--ewmh-state)) + (exwm-layout--set-ewmh-state exwm--id) + (if exwm--floating-frame + (exwm-layout--show exwm--id (frame-root-window exwm--floating-frame)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window exwm--id + :value-mask (logior xcb:ConfigWindow:Sibling + xcb:ConfigWindow:StackMode) + :sibling exwm--guide-window + :stack-mode xcb:StackMode:Above)) + (let ((window (get-buffer-window nil t))) + (when window + (exwm-layout--show exwm--id window)))) + (xcb:flush exwm--connection) + (set-window-dedicated-p (get-buffer-window) nil) + (when (eq 'line-mode exwm--selected-input-mode) + (exwm-input--grab-keyboard exwm--id)))) + +;;;###autoload +(cl-defun exwm-layout-toggle-fullscreen (&optional id) + "Toggle fullscreen mode of X window ID." + (interactive (list (exwm--buffer->id (window-buffer)))) + (exwm--log "id=#x%x" (or id 0)) + (unless (or id (derived-mode-p 'exwm-mode)) + (cl-return-from exwm-layout-toggle-fullscreen)) + (when id + (with-current-buffer (exwm--id->buffer id) + (if (exwm-layout--fullscreen-p) + (exwm-layout-unset-fullscreen id) + (exwm-layout-set-fullscreen id))))) + +(defun exwm-layout--other-buffer-predicate (buffer) + "Return non-nil when the BUFFER may be displayed in selected frame. + +Prevents EXWM-mode buffers already being displayed on some other window from +being selected. + +Should be set as `buffer-predicate' frame parameter for all +frames. Used by `other-buffer'. + +When variable `exwm-layout--other-buffer-exclude-exwm-mode-buffers' +is t EXWM buffers are never selected by `other-buffer'. + +When variable `exwm-layout--other-buffer-exclude-buffers' is a +list of buffers, EXWM buffers belonging to that list are never +selected by `other-buffer'." + (or (not (with-current-buffer buffer (derived-mode-p 'exwm-mode))) + (and (not exwm-layout--other-buffer-exclude-exwm-mode-buffers) + (not (memq buffer exwm-layout--other-buffer-exclude-buffers)) + ;; Do not select if already shown in some window. + (not (get-buffer-window buffer t))))) + +(defun exwm-layout--set-client-list-stacking () + "Set _NET_CLIENT_LIST_STACKING." + (exwm--log) + (let (id clients-floating clients clients-iconic clients-other) + (dolist (pair exwm--id-buffer-alist) + (setq id (car pair)) + (with-current-buffer (cdr pair) + (if (eq exwm--frame exwm-workspace--current) + (if exwm--floating-frame + ;; A floating X window on the current workspace. + (setq clients-floating (cons id clients-floating)) + (if (get-buffer-window (cdr pair) exwm-workspace--current) + ;; A normal tilling X window on the current workspace. + (setq clients (cons id clients)) + ;; An iconic tilling X window on the current workspace. + (setq clients-iconic (cons id clients-iconic)))) + ;; X window on other workspaces. + (setq clients-other (cons id clients-other))))) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_CLIENT_LIST_STACKING + :window exwm--root + :data (vconcat (append clients-other clients-iconic + clients clients-floating)))))) + +(defun exwm-layout--refresh (&optional frame) + "Refresh layout of FRAME. +If FRAME is nil, refresh layout of selected frame." + ;; `window-size-change-functions' sets this argument while + ;; `window-configuration-change-hook' makes the frame selected. + (unless frame + (setq frame (selected-frame))) + (exwm--log "frame=%s" frame) + (if (not (exwm-workspace--workspace-p frame)) + (if (frame-parameter frame 'exwm-outer-id) + (exwm-layout--refresh-floating frame) + (exwm-layout--refresh-other frame)) + (exwm-layout--refresh-workspace frame))) + +(defun exwm-layout--refresh-floating (frame) + "Refresh floating frame FRAME." + (exwm--log "Refresh floating %s" frame) + (let ((window (frame-first-window frame))) + (with-current-buffer (window-buffer window) + (when (and (derived-mode-p 'exwm-mode) + ;; It may be a buffer waiting to be killed. + (exwm--id->buffer exwm--id)) + (exwm--log "Refresh floating window #x%x" exwm--id) + (if (exwm-workspace--active-p exwm--frame) + (exwm-layout--show exwm--id window) + (exwm-layout--hide exwm--id)))))) + +(defun exwm-layout--refresh-other (frame) + "Refresh client or nox frame FRAME." + ;; Other frames (e.g. terminal/graphical frame of emacsclient) + ;; We shall bury all `exwm-mode' buffers in this case + (exwm--log "Refresh other %s" frame) + (let ((windows (window-list frame 'nomini)) ;exclude minibuffer + (exwm-layout--other-buffer-exclude-exwm-mode-buffers t)) + (dolist (window windows) + (with-current-buffer (window-buffer window) + (when (derived-mode-p 'exwm-mode) + (if (window-prev-buffers window) + (switch-to-prev-buffer window) + (switch-to-next-buffer window))))))) + +(defun exwm-layout--refresh-workspace (frame) + "Refresh workspace frame FRAME." + (exwm--log "Refresh workspace %s" frame) + ;; Workspaces other than the active one can also be refreshed (RandR) + (let (covered-buffers ;EXWM-buffers covered by a new X window. + vacated-windows) ;Windows previously displaying EXWM-buffers. + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (when (and (not exwm--floating-frame) ;exclude floating X windows + (or exwm-layout-show-all-buffers + ;; Exclude X windows on other workspaces + (eq frame exwm--frame))) + (let (;; List of windows in current frame displaying the `exwm-mode' + ;; buffers. + (windows (get-buffer-window-list (current-buffer) 'nomini + frame))) + (if (not windows) + (when (eq frame exwm--frame) + ;; Hide it if it was being shown in this workspace. + (exwm-layout--hide exwm--id)) + (let ((window (car windows))) + (if (eq frame exwm--frame) + ;; Show it if `frame' is active, hide otherwise. + (if (exwm-workspace--active-p frame) + (exwm-layout--show exwm--id window) + (exwm-layout--hide exwm--id)) + ;; It was last shown in other workspace; move it here. + (exwm-workspace-move-window frame exwm--id)) + ;; Vacate any other windows (in any workspace) showing this + ;; `exwm-mode' buffer. + (setq vacated-windows + (append vacated-windows (remove + window + (get-buffer-window-list + (current-buffer) 'nomini t)))) + ;; Note any `exwm-mode' buffer is being covered by another + ;; `exwm-mode' buffer. We want to avoid that `exwm-mode' + ;; buffer to be reappear in any of the vacated windows. + (let ((prev-buffer (car-safe + (car-safe (window-prev-buffers window))))) + (and + prev-buffer + (with-current-buffer prev-buffer + (derived-mode-p 'exwm-mode)) + (push prev-buffer covered-buffers))))))))) + ;; Set some sensible buffer to vacated windows. + (let ((exwm-layout--other-buffer-exclude-buffers covered-buffers)) + (dolist (window vacated-windows) + (if (window-prev-buffers window) + (switch-to-prev-buffer window) + (switch-to-next-buffer window)))) + ;; Make sure windows floating / on other workspaces are excluded + (let ((exwm-layout--other-buffer-exclude-exwm-mode-buffers t)) + (dolist (window (window-list frame 'nomini)) + (with-current-buffer (window-buffer window) + (when (and (derived-mode-p 'exwm-mode) + (or exwm--floating-frame (not (eq frame exwm--frame)))) + (if (window-prev-buffers window) + (switch-to-prev-buffer window) + (switch-to-next-buffer window)))))) + (exwm-layout--set-client-list-stacking) + (xcb:flush exwm--connection))) + +(defun exwm-layout--on-minibuffer-setup () + "Refresh layout when minibuffer grows." + (exwm--log) + ;; Only when active minibuffer's frame is an EXWM frame. + (let* ((mini-window (active-minibuffer-window)) + (frame (window-frame mini-window))) + (when (exwm-workspace--workspace-p frame) + (exwm--defer 0 (lambda () + (when (< 1 (window-height mini-window)) + (exwm-layout--refresh frame))))))) + +(defun exwm-layout--on-echo-area-change (&optional dirty) + "Run when message arrives or in `echo-area-clear-hook' to refresh layout. +If DIRTY is non-nil, refresh layout immediately." + (let ((frame (window-frame (active-minibuffer-window))) + (msg (current-message))) + ;; Check whether the frame where current window's minibuffer resides (not + ;; current window's frame for floating windows!) must be adjusted. + (when (and msg + (exwm-workspace--workspace-p frame) + (or (cl-position ?\n msg) + (> (length msg) (frame-width frame)))) + (exwm--log) + (if dirty + (exwm-layout--refresh exwm-workspace--current) + (exwm--defer 0 #'exwm-layout--refresh exwm-workspace--current))))) + +;;;###autoload +(defun exwm-layout-enlarge-window (delta &optional horizontal) + "Make the selected window DELTA pixels taller. + +If no argument is given, make the selected window one pixel taller. If the +optional argument HORIZONTAL is non-nil, make selected window DELTA pixels +wider. If DELTA is negative, shrink selected window by -DELTA pixels. + +Normal hints are checked and regarded if the selected window is displaying an +`exwm-mode' buffer. However, this may violate the normal hints set on other X +windows." + (interactive "p") + (exwm--log) + (cond + ((zerop delta)) ;no operation + ((window-minibuffer-p)) ;avoid resize minibuffer-window + ((not (and (derived-mode-p 'exwm-mode) exwm--floating-frame)) + ;; Resize on tiling layout + (unless (= 0 (window-resizable nil delta horizontal nil t)) ;not resizable + (let ((window-resize-pixelwise t)) + (window-resize nil delta horizontal nil t)))) + ;; Resize on floating layout + (exwm--fixed-size) ;fixed size + (horizontal + (let* ((width (frame-pixel-width)) + (edges (window-inside-pixel-edges)) + (inner-width (- (elt edges 2) (elt edges 0))) + (margin (- width inner-width))) + (if (> delta 0) + (if (not exwm--normal-hints-max-width) + (cl-incf width delta) + (if (>= inner-width exwm--normal-hints-max-width) + (setq width nil) + (setq width (min (+ exwm--normal-hints-max-width margin) + (+ width delta))))) + (if (not exwm--normal-hints-min-width) + (cl-incf width delta) + (if (<= inner-width exwm--normal-hints-min-width) + (setq width nil) + (setq width (max (+ exwm--normal-hints-min-width margin) + (+ width delta)))))) + (when (and width (> width 0)) + (setf (slot-value exwm--geometry 'width) width) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm--floating-frame + 'exwm-outer-id) + :value-mask xcb:ConfigWindow:Width + :width width)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm--floating-frame + 'exwm-container) + :value-mask xcb:ConfigWindow:Width + :width width)) + (xcb:flush exwm--connection)))) + (t + (let* ((height (+ (frame-pixel-height) exwm-workspace--frame-y-offset)) + (edges (window-inside-pixel-edges)) + (inner-height (- (elt edges 3) (elt edges 1))) + (margin (- height inner-height))) + (if (> delta 0) + (if (not exwm--normal-hints-max-height) + (cl-incf height delta) + (if (>= inner-height exwm--normal-hints-max-height) + (setq height nil) + (setq height (min (+ exwm--normal-hints-max-height margin) + (+ height delta))))) + (if (not exwm--normal-hints-min-height) + (cl-incf height delta) + (if (<= inner-height exwm--normal-hints-min-height) + (setq height nil) + (setq height (max (+ exwm--normal-hints-min-height margin) + (+ height delta)))))) + (when (and height (> height 0)) + (setf (slot-value exwm--geometry 'height) height) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm--floating-frame + 'exwm-outer-id) + :value-mask xcb:ConfigWindow:Height + :height height)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm--floating-frame + 'exwm-container) + :value-mask xcb:ConfigWindow:Height + :height height)) + (xcb:flush exwm--connection)))))) + +;;;###autoload +(defun exwm-layout-enlarge-window-horizontally (delta) + "Make the selected window DELTA pixels wider. + +See also `exwm-layout-enlarge-window'." + (interactive "p") + (exwm--log "%s" delta) + (exwm-layout-enlarge-window delta t)) + +;;;###autoload +(defun exwm-layout-shrink-window (delta) + "Make the selected window DELTA pixels lower. + +See also `exwm-layout-enlarge-window'." + (interactive "p") + (exwm--log "%s" delta) + (exwm-layout-enlarge-window (- delta))) + +;;;###autoload +(defun exwm-layout-shrink-window-horizontally (delta) + "Make the selected window DELTA pixels narrower. + +See also `exwm-layout-enlarge-window'." + (interactive "p") + (exwm--log "%s" delta) + (exwm-layout-enlarge-window (- delta) t)) + +;;;###autoload +(defun exwm-layout-hide-mode-line () + "Hide mode-line." + (interactive) + (exwm--log) + (when (and (derived-mode-p 'exwm-mode) mode-line-format) + (let (mode-line-height) + (when exwm--floating-frame + (setq mode-line-height (window-mode-line-height + (frame-root-window exwm--floating-frame)))) + (setq exwm--mode-line-format mode-line-format + mode-line-format nil) + (if (not exwm--floating-frame) + (exwm-layout--show exwm--id) + (set-frame-height exwm--floating-frame + (- (frame-pixel-height exwm--floating-frame) + mode-line-height) + nil t))))) + +;;;###autoload +(defun exwm-layout-show-mode-line () + "Show mode-line." + (interactive) + (exwm--log) + (when (and (derived-mode-p 'exwm-mode) (not mode-line-format)) + (setq mode-line-format exwm--mode-line-format + exwm--mode-line-format nil) + (if (not exwm--floating-frame) + (exwm-layout--show exwm--id) + (set-frame-height exwm--floating-frame + (+ (frame-pixel-height exwm--floating-frame) + (window-mode-line-height (frame-root-window + exwm--floating-frame))) + nil t) + (call-interactively #'exwm-input-grab-keyboard)) + (force-mode-line-update))) + +;;;###autoload +(defun exwm-layout-toggle-mode-line () + "Toggle the display of mode-line." + (interactive) + (exwm--log) + (when (derived-mode-p 'exwm-mode) + (if mode-line-format + (exwm-layout-hide-mode-line) + (exwm-layout-show-mode-line)))) + +(defun exwm-layout--init () + "Initialize layout module." + ;; Auto refresh layout + (exwm--log) + (add-hook 'window-configuration-change-hook #'exwm-layout--refresh) + ;; The behavior of `window-configuration-change-hook' will be changed. + (when (fboundp 'window-pixel-width-before-size-change) + (add-hook 'window-size-change-functions #'exwm-layout--refresh)) + (unless (exwm-workspace--minibuffer-own-frame-p) + ;; Refresh when minibuffer grows + (add-hook 'minibuffer-setup-hook #'exwm-layout--on-minibuffer-setup t) + (setq exwm-layout--timer + (run-with-idle-timer 0 t #'exwm-layout--on-echo-area-change t)) + (add-hook 'echo-area-clear-hook #'exwm-layout--on-echo-area-change))) + +(defun exwm-layout--exit () + "Exit the layout module." + (exwm--log) + (remove-hook 'window-configuration-change-hook #'exwm-layout--refresh) + (when (fboundp 'window-pixel-width-before-size-change) + (remove-hook 'window-size-change-functions #'exwm-layout--refresh)) + (remove-hook 'minibuffer-setup-hook #'exwm-layout--on-minibuffer-setup) + (when exwm-layout--timer + (cancel-timer exwm-layout--timer) + (setq exwm-layout--timer nil)) + (remove-hook 'echo-area-clear-hook #'exwm-layout--on-echo-area-change)) + + + +(provide 'exwm-layout) + +;;; exwm-layout.el ends here diff --git a/third_party/exwm/exwm-manage.el b/third_party/exwm/exwm-manage.el new file mode 100644 index 0000000000..ab66e298ac --- /dev/null +++ b/third_party/exwm/exwm-manage.el @@ -0,0 +1,833 @@ +;;; exwm-manage.el --- Window Management Module for -*- lexical-binding: t -*- +;;; EXWM + +;; Copyright (C) 2015-2024 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This is the fundamental module of EXWM that deals with window management. + +;;; Code: + +(require 'exwm-core) + +(defgroup exwm-manage nil + "Manage." + :group 'exwm) + +(defcustom exwm-manage-finish-hook nil + "Normal hook run after a window is just managed. +This hook runs in the context of the corresponding `exwm-mode' buffer." + :type 'hook) + +(defcustom exwm-manage-force-tiling nil + "Non-nil to force managing all X windows in tiling layout. +You can still make the X windows floating afterwards." + :type 'boolean) + +(defcustom exwm-manage-ping-timeout 3 + "Seconds to wait before killing a client." + :type 'integer) + +(defcustom exwm-manage-configurations nil + "Per-application configurations. + +Configuration options allow to override various default behaviors of EXWM +and only take effect when they are present. Note for certain options +specifying nil is not exactly the same as leaving them out. Currently +possible choices: +* floating: Force floating (non-nil) or tiling (nil) on startup. +* x/y/width/height: Override the initial geometry (floating X window only). +* border-width: Override the border width (only visible when floating). +* fullscreen: Force full screen (non-nil) on startup. +* floating-mode-line: `mode-line-format' used when floating. +* tiling-mode-line: `mode-line-format' used when tiling. +* floating-header-line: `header-line-format' used when floating. +* tiling-header-line: `header-line-format' used when tiling. +* char-mode: Force char-mode (non-nil) on startup. +* prefix-keys: `exwm-input-prefix-keys' local to this X window. +* simulation-keys: `exwm-input-simulation-keys' local to this X window. +* workspace: The initial workspace. +* managed: Force to manage (non-nil) or not manage (nil) the X window. + +For each X window managed for the first time, matching criteria (sexps) are +evaluated sequentially and the first configuration with a non-nil matching +criterion would be applied. Apart from generic forms, one would typically +want to match against EXWM internal variables such as `exwm-title', +`exwm-class-name' and `exwm-instance-name'." + :type '(alist :key-type (sexp :tag "Matching criterion" nil) + :value-type + (plist :tag "Configurations" + :options + (((const :tag "Floating" floating) boolean) + ((const :tag "X" x) number) + ((const :tag "Y" y) number) + ((const :tag "Width" width) number) + ((const :tag "Height" height) number) + ((const :tag "Border width" border-width) integer) + ((const :tag "Fullscreen" fullscreen) boolean) + ((const :tag "Floating mode-line" floating-mode-line) + sexp) + ((const :tag "Tiling mode-line" tiling-mode-line) sexp) + ((const :tag "Floating header-line" + floating-header-line) + sexp) + ((const :tag "Tiling header-line" tiling-header-line) + sexp) + ((const :tag "Char-mode" char-mode) boolean) + ((const :tag "Prefix keys" prefix-keys) + (repeat key-sequence)) + ((const :tag "Simulation keys" simulation-keys) + (alist :key-type (key-sequence :tag "From") + :value-type (key-sequence :tag "To"))) + ((const :tag "Workspace" workspace) integer) + ((const :tag "Managed" managed) boolean) + ;; For forward compatibility. + ((other) sexp)))) + ;; TODO: This is admittedly ugly. We'd be better off with an event type. + :get (lambda (symbol) + (mapcar (lambda (pair) + (let* ((match (car pair)) + (config (cdr pair)) + (prefix-keys (plist-get config 'prefix-keys))) + (when prefix-keys + (setq config (copy-tree config) + config (plist-put config 'prefix-keys + (mapcar (lambda (i) + (if (sequencep i) + i + (vector i))) + prefix-keys)))) + (cons match config))) + (default-value symbol))) + :set (lambda (symbol value) + (set symbol + (mapcar (lambda (pair) + (let* ((match (car pair)) + (config (cdr pair)) + (prefix-keys (plist-get config 'prefix-keys))) + (when prefix-keys + (setq config (copy-tree config) + config (plist-put config 'prefix-keys + (mapcar (lambda (i) + (if (sequencep i) + (aref i 0) + i)) + prefix-keys)))) + (cons match config))) + value)))) + +;; FIXME: Make the following values as small as possible. +(defconst exwm-manage--height-delta-min 5) +(defconst exwm-manage--width-delta-min 5) + +;; The _MOTIF_WM_HINTS atom (see <Xm/MwmUtil.h> for more details) +;; It's currently only used in 'exwm-manage' module +(defvar exwm-manage--_MOTIF_WM_HINTS nil "_MOTIF_WM_HINTS atom.") + +(defvar exwm-manage--desktop nil "The desktop X window.") + +(defvar exwm-manage--frame-outer-id-list nil + "List of window-outer-id's of all frames.") + +(defvar exwm-manage--ping-lock nil + "Non-nil indicates EXWM is pinging a window.") + +(defvar exwm-input--skip-buffer-list-update) +(defvar exwm-input-prefix-keys) +(defvar exwm-workspace--current) +(defvar exwm-workspace--id-struts-alist) +(defvar exwm-workspace--list) +(defvar exwm-workspace--switch-history-outdated) +(defvar exwm-workspace-current-index) +(declare-function exwm--update-class "exwm.el" (id &optional force)) +(declare-function exwm--update-hints "exwm.el" (id &optional force)) +(declare-function exwm--update-normal-hints "exwm.el" (id &optional force)) +(declare-function exwm--update-protocols "exwm.el" (id &optional force)) +(declare-function exwm--update-struts "exwm.el" (id)) +(declare-function exwm--update-title "exwm.el" (id)) +(declare-function exwm--update-transient-for "exwm.el" (id &optional force)) +(declare-function exwm--update-desktop "exwm.el" (id &optional force)) +(declare-function exwm--update-window-type "exwm.el" (id &optional force)) +(declare-function exwm-floating--set-floating "exwm-floating.el" (id)) +(declare-function exwm-floating--unset-floating "exwm-floating.el" (id)) +(declare-function exwm-input-grab-keyboard "exwm-input.el" (&optional id)) +(declare-function exwm-input-release-keyboard "exwm-input.el" (&optional id)) +(declare-function exwm-input-set-local-simulation-keys "exwm-input.el") +(declare-function exwm-layout--fullscreen-p "exwm-layout.el" ()) +(declare-function exwm-layout--iconic-state-p "exwm-layout.el" (&optional id)) +(declare-function exwm-layout-set-fullscreen "exwm-layout.el" (&optional id)) +(declare-function exwm-workspace--get-geometry "exwm-workspace.el" (frame)) +(declare-function exwm-workspace--position "exwm-workspace.el" (frame)) +(declare-function exwm-workspace--set-fullscreen "exwm-workspace.el" (frame)) +(declare-function exwm-workspace--update-struts "exwm-workspace.el" ()) +(declare-function exwm-workspace--update-workareas "exwm-workspace.el" ()) +(declare-function exwm-workspace--workarea "exwm-workspace.el" (frame)) + +(defun exwm-manage--update-geometry (id &optional force) + "Update geometry of X window ID. +Override current geometry if FORCE is non-nil." + (exwm--log "id=#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (and exwm--geometry (not force)) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry :drawable id)))) + (setq exwm--geometry + (or reply + ;; Provide a reasonable fallback value. + (make-instance 'xcb:RECTANGLE + :x 0 + :y 0 + :width (/ (x-display-pixel-width) 2) + :height (/ (x-display-pixel-height) 2)))))))) + +(defun exwm-manage--update-ewmh-state (id) + "Update _NET_WM_STATE of X window ID." + (exwm--log "id=#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless exwm--ewmh-state + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:ewmh:get-_NET_WM_STATE + :window id)))) + (when reply + (setq exwm--ewmh-state (append (slot-value reply 'value) nil))))))) + +(defun exwm-manage--update-mwm-hints (id &optional force) + "Update _MOTIF_WM_HINTS of X window ID. +Override current hinds if FORCE is non-nil." + (exwm--log "id=#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (and (not exwm--mwm-hints-decorations) (not force)) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:icccm:-GetProperty + :window id + :property exwm-manage--_MOTIF_WM_HINTS + :type exwm-manage--_MOTIF_WM_HINTS + :long-length 5)))) + (when reply + ;; Check MotifWmHints.decorations. + (with-slots (value) reply + (setq value (append value nil)) + (when (and value + ;; See <Xm/MwmUtil.h> for fields definitions. + (/= 0 (logand + (elt value 0) ;MotifWmHints.flags + 2)) ;MWM_HINTS_DECORATIONS + (= 0 + (elt value 2))) ;MotifWmHints.decorations + (setq exwm--mwm-hints-decorations nil)))))))) + +(defun exwm-manage--update-default-directory (id) + "Update the `default-directory' of X window ID. +Sets the `default-directory' of the EXWM buffer associated with X window to +match its current working directory. + +This only works when procfs is mounted, which may not be the case on some BSDs." + (with-current-buffer (exwm--id->buffer id) + (if-let* ((response (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:ewmh:get-_NET_WM_PID + :window id))) + (pid (slot-value response 'value)) + (cwd (file-symlink-p (format "/proc/%d/cwd" pid))) + ((file-accessible-directory-p cwd))) + (setq default-directory (file-name-as-directory cwd)) + (setq default-directory (expand-file-name "~/"))))) + + +(defun exwm-manage--set-client-list () + "Set _NET_CLIENT_LIST." + (exwm--log) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_CLIENT_LIST + :window exwm--root + :data (vconcat (mapcar #'car exwm--id-buffer-alist))))) + +(cl-defun exwm-manage--get-configurations () + "Retrieve configurations for this buffer." + (exwm--log) + (when (derived-mode-p 'exwm-mode) + (dolist (i exwm-manage-configurations) + (save-current-buffer + (when (with-demoted-errors "Problematic configuration: %S" + (eval (car i) t)) + (cl-return-from exwm-manage--get-configurations (cdr i))))))) + +(defun exwm-manage--manage-window (id) + "Manage window ID." + (exwm--log "Try to manage #x%x" id) + (catch 'return + ;; Ensure it's alive + (when (xcb:+request-checked+request-check exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window id :value-mask xcb:CW:EventMask + :event-mask (exwm--get-client-event-mask))) + (throw 'return 'dead)) + ;; Add this X window to save-set. + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeSaveSet + :mode xcb:SetMode:Insert + :window id)) + (with-current-buffer (let ((exwm-input--skip-buffer-list-update t)) + (generate-new-buffer "*EXWM*")) + ;; Keep the oldest X window first. + (setq exwm--id-buffer-alist + (nconc exwm--id-buffer-alist `((,id . ,(current-buffer))))) + (exwm-mode) + (setq exwm--id id + exwm--frame exwm-workspace--current) + (exwm--update-window-type id) + (exwm--update-class id) + (exwm--update-transient-for id) + (exwm--update-normal-hints id) + (exwm--update-hints id) + (exwm-manage--update-geometry id) + (exwm-manage--update-mwm-hints id) + (exwm--update-title id) + (exwm--update-protocols id) + (setq exwm--configurations (exwm-manage--get-configurations)) + ;; OverrideRedirect is not checked here. + (when (and + ;; The user has specified to manage it. + (not (plist-get exwm--configurations 'managed)) + (or + ;; The user has specified not to manage it. + (plist-member exwm--configurations 'managed) + ;; This is not a type of X window we can manage. + (and exwm-window-type + (not (cl-intersection + exwm-window-type + (list xcb:Atom:_NET_WM_WINDOW_TYPE_UTILITY + xcb:Atom:_NET_WM_WINDOW_TYPE_DIALOG + xcb:Atom:_NET_WM_WINDOW_TYPE_NORMAL)))) + ;; Check the _MOTIF_WM_HINTS property to not manage floating X + ;; windows without decoration. + (and (not exwm--mwm-hints-decorations) + (not exwm--hints-input) + ;; Floating windows only + (or exwm-transient-for exwm--fixed-size + (memq xcb:Atom:_NET_WM_WINDOW_TYPE_UTILITY + exwm-window-type) + (memq xcb:Atom:_NET_WM_WINDOW_TYPE_DIALOG + exwm-window-type))))) + (exwm--log "No need to manage #x%x" id) + ;; Update struts. + (when (memq xcb:Atom:_NET_WM_WINDOW_TYPE_DOCK exwm-window-type) + (exwm--update-struts id)) + ;; Remove all events + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window id :value-mask xcb:CW:EventMask + :event-mask + (if (memq xcb:Atom:_NET_WM_WINDOW_TYPE_DOCK + exwm-window-type) + ;; Listen for PropertyChange (struts) and + ;; UnmapNotify/DestroyNotify event of the dock. + (exwm--get-client-event-mask) + xcb:EventMask:NoEvent))) + ;; The window needs to be mapped + (xcb:+request exwm--connection + (make-instance 'xcb:MapWindow :window id)) + (with-slots (x y width height) exwm--geometry + ;; Center window of type _NET_WM_WINDOW_TYPE_SPLASH + (when (memq xcb:Atom:_NET_WM_WINDOW_TYPE_SPLASH exwm-window-type) + (with-slots ((x* x) (y* y) (width* width) (height* height)) + (exwm-workspace--workarea exwm--frame) + (exwm--set-geometry id + (+ x* (/ (- width* width) 2)) + (+ y* (/ (- height* height) 2)) + nil + nil)))) + ;; Check for desktop. + (when (memq xcb:Atom:_NET_WM_WINDOW_TYPE_DESKTOP exwm-window-type) + ;; There should be only one desktop X window. + (setq exwm-manage--desktop id) + ;; Put it at bottom. + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window id + :value-mask xcb:ConfigWindow:StackMode + :stack-mode xcb:StackMode:Below))) + (xcb:flush exwm--connection) + (setq exwm--id-buffer-alist (assq-delete-all id exwm--id-buffer-alist)) + (let ((kill-buffer-query-functions nil) + (exwm-input--skip-buffer-list-update t)) + (kill-buffer (current-buffer))) + (throw 'return 'ignored)) + (let ((index (plist-get exwm--configurations 'workspace))) + (when (and index (< index (length exwm-workspace--list))) + (setq exwm--frame (elt exwm-workspace--list index)))) + ;; Manage the window + (exwm--log "Manage #x%x" id) + (xcb:+request exwm--connection ;remove border + (make-instance 'xcb:ConfigureWindow + :window id :value-mask xcb:ConfigWindow:BorderWidth + :border-width 0)) + (dolist (button ;grab buttons to set focus / move / resize + (list xcb:ButtonIndex:1 xcb:ButtonIndex:2 xcb:ButtonIndex:3)) + (xcb:+request exwm--connection + (make-instance 'xcb:GrabButton + :owner-events 0 :grab-window id + :event-mask xcb:EventMask:ButtonPress + :pointer-mode xcb:GrabMode:Sync + :keyboard-mode xcb:GrabMode:Async + :confine-to xcb:Window:None :cursor xcb:Cursor:None + :button button :modifiers xcb:ModMask:Any))) + (exwm-manage--set-client-list) + (xcb:flush exwm--connection) + (if (plist-member exwm--configurations 'floating) + ;; User has specified whether it should be floating. + (if (plist-get exwm--configurations 'floating) + (exwm-floating--set-floating id) + (with-selected-window (frame-selected-window exwm--frame) + (exwm-floating--unset-floating id))) + ;; Try to determine if it should be floating. + (if (and (not exwm-manage-force-tiling) + (or exwm-transient-for exwm--fixed-size + (memq xcb:Atom:_NET_WM_WINDOW_TYPE_UTILITY + exwm-window-type) + (memq xcb:Atom:_NET_WM_WINDOW_TYPE_DIALOG + exwm-window-type))) + (exwm-floating--set-floating id) + (with-selected-window (frame-selected-window exwm--frame) + (exwm-floating--unset-floating id)))) + (if (plist-get exwm--configurations 'char-mode) + (exwm-input-release-keyboard id) + (exwm-input-grab-keyboard id)) + (when-let ((simulation-keys (plist-get exwm--configurations 'simulation-keys))) + (exwm-input-set-local-simulation-keys simulation-keys)) + (when-let ((prefix-keys (plist-get exwm--configurations 'prefix-keys))) + (setq-local exwm-input-prefix-keys prefix-keys)) + (setq exwm-workspace--switch-history-outdated t) + (exwm--update-desktop id) + (exwm-manage--update-ewmh-state id) + (exwm-manage--update-default-directory id) + (when (or (plist-get exwm--configurations 'fullscreen) + (exwm-layout--fullscreen-p)) + (setq exwm--ewmh-state (delq xcb:Atom:_NET_WM_STATE_FULLSCREEN + exwm--ewmh-state)) + (exwm-layout-set-fullscreen id)) + (run-hooks 'exwm-manage-finish-hook)))) + +(defun exwm-manage--unmanage-window (id &optional withdraw-only) + "Unmanage window ID. + +If WITHDRAW-ONLY is non-nil, the X window will be properly placed back to the +root window. Set WITHDRAW-ONLY to `quit' if this functions is used when window +manager is shutting down." + (let ((buffer (exwm--id->buffer id))) + (exwm--log "Unmanage #x%x (buffer: %s, widthdraw: %s)" + id buffer withdraw-only) + (setq exwm--id-buffer-alist (assq-delete-all id exwm--id-buffer-alist)) + ;; Update workspaces when a dock is destroyed. + (when (and (null withdraw-only) + (assq id exwm-workspace--id-struts-alist)) + (setq exwm-workspace--id-struts-alist + (assq-delete-all id exwm-workspace--id-struts-alist)) + (exwm-workspace--update-struts) + (exwm-workspace--update-workareas) + (dolist (f exwm-workspace--list) + (exwm-workspace--set-fullscreen f))) + (when (and (buffer-live-p buffer) + ;; Invoked from `exwm-manage--exit' upon disconnection. + (slot-value exwm--connection 'connected)) + (with-current-buffer buffer + ;; Unmap the X window. + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow :window id)) + ;; + (setq exwm-workspace--switch-history-outdated t) + ;; + (when withdraw-only + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window id :value-mask xcb:CW:EventMask + :event-mask xcb:EventMask:NoEvent)) + ;; Delete WM_STATE property + (xcb:+request exwm--connection + (make-instance 'xcb:DeleteProperty + :window id :property xcb:Atom:WM_STATE)) + (cond + ((eq withdraw-only 'quit) + ;; Remap the window when exiting. + (xcb:+request exwm--connection + (make-instance 'xcb:MapWindow :window id))) + (t + ;; Remove _NET_WM_DESKTOP. + (xcb:+request exwm--connection + (make-instance 'xcb:DeleteProperty + :window id + :property xcb:Atom:_NET_WM_DESKTOP))))) + (when exwm--floating-frame + ;; Unmap the floating frame before destroying its container. + (let ((window (frame-parameter exwm--floating-frame 'exwm-outer-id)) + (container (frame-parameter exwm--floating-frame + 'exwm-container))) + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow :window window)) + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window window :parent exwm--root :x 0 :y 0)) + (xcb:+request exwm--connection + (make-instance 'xcb:DestroyWindow :window container)))) + (when (exwm-layout--fullscreen-p) + (let ((window (get-buffer-window))) + (when window + (set-window-dedicated-p window nil)))) + (exwm-manage--set-client-list) + (xcb:flush exwm--connection)) + (let ((kill-buffer-func + (lambda (buffer) + (when (buffer-local-value 'exwm--floating-frame buffer) + (select-window + (frame-selected-window exwm-workspace--current))) + (with-current-buffer buffer + (let ((kill-buffer-query-functions nil)) + (kill-buffer buffer)))))) + (exwm--defer 0 kill-buffer-func buffer) + (when (active-minibuffer-window) + (exit-minibuffer)))))) + +(defun exwm-manage--scan () + "Search for existing windows and try to manage them." + (exwm--log) + (let* ((tree (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:QueryTree + :window exwm--root))) + reply) + (dolist (i (slot-value tree 'children)) + (setq reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetWindowAttributes + :window i))) + ;; It's possible the X window has been destroyed. + (when reply + (with-slots (override-redirect map-state) reply + (when (and (= 0 override-redirect) + (= xcb:MapState:Viewable map-state)) + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow + :window i)) + (xcb:flush exwm--connection) + (exwm-manage--manage-window i))))))) + +(defun exwm-manage--kill-buffer-query-function () + "Run in `kill-buffer-query-functions'." + (exwm--log "id=#x%x; buffer=%s" (or exwm--id 0) (current-buffer)) + (catch 'return + (when (or (not exwm--connection) + (not (slot-value exwm--connection 'connected))) + (throw 'return t)) + (when (or (not exwm--id) + (xcb:+request-checked+request-check exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window exwm--id + :value-mask xcb:CW:EventMask + :event-mask (exwm--get-client-event-mask)))) + ;; The X window is no longer alive so just close the buffer. + (when exwm--floating-frame + (let ((window (frame-parameter exwm--floating-frame 'exwm-outer-id)) + (container (frame-parameter exwm--floating-frame + 'exwm-container))) + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow :window window)) + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window window + :parent exwm--root + :x 0 :y 0)) + (xcb:+request exwm--connection + (make-instance 'xcb:DestroyWindow + :window container)))) + (xcb:flush exwm--connection) + (throw 'return t)) + (unless (memq xcb:Atom:WM_DELETE_WINDOW exwm--protocols) + ;; The X window does not support WM_DELETE_WINDOW; destroy it. + (xcb:+request exwm--connection + (make-instance 'xcb:DestroyWindow :window exwm--id)) + (xcb:flush exwm--connection) + ;; Wait for DestroyNotify event. + (throw 'return nil)) + (let ((id exwm--id)) + ;; Try to close the X window with WM_DELETE_WINDOW client message. + (xcb:+request exwm--connection + (make-instance 'xcb:icccm:SendEvent + :destination id + :event (xcb:marshal + (make-instance 'xcb:icccm:WM_DELETE_WINDOW + :window id) + exwm--connection))) + (xcb:flush exwm--connection) + ;; + (unless (memq xcb:Atom:_NET_WM_PING exwm--protocols) + ;; For X windows without _NET_WM_PING support, we'd better just + ;; wait for DestroyNotify events. + (throw 'return nil)) + ;; Try to determine if the X window is dead with _NET_WM_PING. + (setq exwm-manage--ping-lock t) + (xcb:+request exwm--connection + (make-instance 'xcb:SendEvent + :propagate 0 + :destination id + :event-mask xcb:EventMask:NoEvent + :event (xcb:marshal + (make-instance 'xcb:ewmh:_NET_WM_PING + :window id + :timestamp 0 + :client-window id) + exwm--connection))) + (xcb:flush exwm--connection) + (with-timeout (exwm-manage-ping-timeout + (if (y-or-n-p (format "'%s' is not responding. \ +Would you like to kill it? " + (buffer-name))) + (progn (exwm-manage--kill-client id) + ;; Kill the unresponsive X window and + ;; wait for DestroyNotify event. + (throw 'return nil)) + ;; Give up. + (throw 'return nil))) + (while (and exwm-manage--ping-lock + (exwm--id->buffer id)) ;may have been destroyed. + (accept-process-output nil 0.1)) + ;; Give up. + (throw 'return nil))))) + +(defun exwm-manage--kill-client (&optional id) + "Kill X client ID. +If ID is nil, kill X window corresponding to current buffer." + (unless id (setq id (exwm--buffer->id (current-buffer)))) + (exwm--log "id=#x%x" id) + (let* ((response (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:ewmh:get-_NET_WM_PID :window id))) + (pid (and response (slot-value response 'value))) + (request (make-instance 'xcb:KillClient :resource id))) + (if (not pid) + (xcb:+request exwm--connection request) + ;; What if the PID is fake/wrong? + (signal-process pid 'SIGKILL) + ;; Ensure it's dead + (run-with-timer exwm-manage-ping-timeout nil + (lambda () + (xcb:+request exwm--connection request)))) + (xcb:flush exwm--connection))) + +(defun exwm-manage--add-frame (frame) + "Run in `after-make-frame-functions'. +FRAME is the newly created frame." + (exwm--log "frame=%s" frame) + (when (display-graphic-p frame) + (push (string-to-number (frame-parameter frame 'outer-window-id)) + exwm-manage--frame-outer-id-list))) + +(defun exwm-manage--remove-frame (frame) + "Run in `delete-frame-functions'. +FRAME is the frame to be deleted." + (exwm--log "frame=%s" frame) + (when (display-graphic-p frame) + (setq exwm-manage--frame-outer-id-list + (delq (string-to-number (frame-parameter frame 'outer-window-id)) + exwm-manage--frame-outer-id-list)))) + +(defun exwm-manage--on-ConfigureRequest (data _synthetic) + "Handle ConfigureRequest event. +DATA contains unmarshalled ConfigureRequest event data." + (exwm--log) + (let ((obj (make-instance 'xcb:ConfigureRequest)) + buffer edges width-delta height-delta) + (xcb:unmarshal obj data) + (with-slots (window x y width height + border-width sibling stack-mode value-mask) + obj + (exwm--log "#x%x (#x%x) @%dx%d%+d%+d; \ +border-width: %d; sibling: #x%x; stack-mode: %d" + window value-mask width height x y + border-width sibling stack-mode) + (if (and (setq buffer (exwm--id->buffer window)) + (with-current-buffer buffer + (or (exwm-layout--fullscreen-p) + ;; Make sure it's a floating X window wanting to resize + ;; itself. + (or (not exwm--floating-frame) + (progn + (setq edges + (window-inside-pixel-edges + (get-buffer-window buffer t)) + width-delta (- width (- (elt edges 2) + (elt edges 0))) + height-delta (- height (- (elt edges 3) + (elt edges 1)))) + ;; We cannot do resizing precisely for now. + (and (if (= 0 (logand value-mask + xcb:ConfigWindow:Width)) + t + (< (abs width-delta) + exwm-manage--width-delta-min)) + (if (= 0 (logand value-mask + xcb:ConfigWindow:Height)) + t + (< (abs height-delta) + exwm-manage--height-delta-min)))))))) + ;; Send client message for managed windows + (with-current-buffer buffer + (setq edges + (if (exwm-layout--fullscreen-p) + (with-slots (x y width height) + (exwm-workspace--get-geometry exwm--frame) + (list x y width height)) + (window-inside-absolute-pixel-edges + (get-buffer-window buffer t)))) + (exwm--log "Reply with ConfigureNotify (edges): %s" edges) + (xcb:+request exwm--connection + (make-instance 'xcb:SendEvent + :propagate 0 :destination window + :event-mask xcb:EventMask:StructureNotify + :event (xcb:marshal + (make-instance + 'xcb:ConfigureNotify + :event window :window window + :above-sibling xcb:Window:None + :x (elt edges 0) :y (elt edges 1) + :width (- (elt edges 2) (elt edges 0)) + :height (- (elt edges 3) (elt edges 1)) + :border-width 0 :override-redirect 0) + exwm--connection)))) + (if buffer + (with-current-buffer buffer + (exwm--log "ConfigureWindow (resize floating X window)") + (exwm--set-geometry (frame-parameter exwm--floating-frame + 'exwm-outer-id) + nil + nil + (+ (frame-pixel-width exwm--floating-frame) + width-delta) + (+ (frame-pixel-height exwm--floating-frame) + height-delta))) + (exwm--log "ConfigureWindow (preserve geometry)") + ;; Configure the unmanaged window. + ;; But Emacs frames should be excluded. Generally we don't + ;; receive ConfigureRequest events from Emacs frames since we + ;; have set OverrideRedirect on them, but this is not true for + ;; Lucid build (as of 25.1). + (unless (memq window exwm-manage--frame-outer-id-list) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window window + :value-mask value-mask + :x x :y y :width width :height height + :border-width border-width + :sibling sibling + :stack-mode stack-mode))))))) + (xcb:flush exwm--connection)) + +(defun exwm-manage--on-MapRequest (data _synthetic) + "Handle MapRequest event. +DATA contains unmarshalled MapRequest event data." + (let ((obj (make-instance 'xcb:MapRequest))) + (xcb:unmarshal obj data) + (with-slots (parent window) obj + (exwm--log "id=#x%x parent=#x%x" window parent) + (if (assoc window exwm--id-buffer-alist) + (with-current-buffer (exwm--id->buffer window) + (if (exwm-layout--iconic-state-p) + ;; State change: iconic => normal. + (when (eq exwm--frame exwm-workspace--current) + (pop-to-buffer-same-window (current-buffer))) + (exwm--log "#x%x is already managed" window))) + (if (/= exwm--root parent) + (progn (xcb:+request exwm--connection + (make-instance 'xcb:MapWindow :window window)) + (xcb:flush exwm--connection)) + (exwm--log "#x%x" window) + (exwm-manage--manage-window window)))))) + +(defun exwm-manage--on-UnmapNotify (data _synthetic) + "Handle UnmapNotify event. +DATA contains unmarshalled UnmapNotify event data." + (let ((obj (make-instance 'xcb:UnmapNotify))) + (xcb:unmarshal obj data) + (with-slots (window) obj + (exwm--log "id=#x%x" window) + (exwm-manage--unmanage-window window t)))) + +(defun exwm-manage--on-MapNotify (data _synthetic) + "Handle MapNotify event. +DATA contains unmarshalled MapNotify event data." + (let ((obj (make-instance 'xcb:MapNotify))) + (xcb:unmarshal obj data) + (with-slots (window) obj + (when (assoc window exwm--id-buffer-alist) + (exwm--log "id=#x%x" window) + ;; With this we ensure that a "window hierarchy change" happens after + ;; mapping the window, as some servers (XQuartz) do not generate it. + (with-current-buffer (exwm--id->buffer window) + (if exwm--floating-frame + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window window + :value-mask xcb:ConfigWindow:StackMode + :stack-mode xcb:StackMode:Above)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window window + :value-mask (logior xcb:ConfigWindow:Sibling + xcb:ConfigWindow:StackMode) + :sibling exwm--guide-window + :stack-mode xcb:StackMode:Above)))) + (xcb:flush exwm--connection))))) + +(defun exwm-manage--on-DestroyNotify (data synthetic) + "Handle DestroyNotify event. +DATA contains unmarshalled DestroyNotify event data. +SYNTHETIC indicates whether the event is a synthetic event." + (unless synthetic + (exwm--log) + (let ((obj (make-instance 'xcb:DestroyNotify))) + (xcb:unmarshal obj data) + (exwm--log "#x%x" (slot-value obj 'window)) + (exwm-manage--unmanage-window (slot-value obj 'window))))) + +(defun exwm-manage--init () + "Initialize manage module." + ;; Intern _MOTIF_WM_HINTS + (exwm--log) + (setq exwm-manage--_MOTIF_WM_HINTS (exwm--intern-atom "_MOTIF_WM_HINTS")) + (add-hook 'after-make-frame-functions #'exwm-manage--add-frame) + (add-hook 'delete-frame-functions #'exwm-manage--remove-frame) + (xcb:+event exwm--connection 'xcb:ConfigureRequest + #'exwm-manage--on-ConfigureRequest) + (xcb:+event exwm--connection 'xcb:MapRequest #'exwm-manage--on-MapRequest) + (xcb:+event exwm--connection 'xcb:UnmapNotify #'exwm-manage--on-UnmapNotify) + (xcb:+event exwm--connection 'xcb:MapNotify #'exwm-manage--on-MapNotify) + (xcb:+event exwm--connection 'xcb:DestroyNotify + #'exwm-manage--on-DestroyNotify)) + +(defun exwm-manage--exit () + "Exit the manage module." + (exwm--log) + (dolist (pair exwm--id-buffer-alist) + (exwm-manage--unmanage-window (car pair) 'quit)) + (remove-hook 'after-make-frame-functions #'exwm-manage--add-frame) + (remove-hook 'delete-frame-functions #'exwm-manage--remove-frame) + (setq exwm-manage--_MOTIF_WM_HINTS nil)) + + + +(provide 'exwm-manage) + +;;; exwm-manage.el ends here diff --git a/third_party/exwm/exwm-randr.el b/third_party/exwm/exwm-randr.el new file mode 100644 index 0000000000..7f0e50559b --- /dev/null +++ b/third_party/exwm/exwm-randr.el @@ -0,0 +1,369 @@ +;;; exwm-randr.el --- RandR Module for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2024 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module adds RandR support for EXWM. Currently it requires external +;; tools such as xrandr(1) to properly configure RandR first. This +;; dependency may be removed in the future, but more work is needed before +;; that. + +;; To use this module, load, enable it and configure +;; `exwm-randr-workspace-monitor-plist' and `exwm-randr-screen-change-hook' +;; as follows: +;; +;; (require 'exwm-randr) +;; (setq exwm-randr-workspace-monitor-plist '(0 "VGA1")) +;; (add-hook 'exwm-randr-screen-change-hook +;; (lambda () +;; (start-process-shell-command +;; "xrandr" nil "xrandr --output VGA1 --left-of LVDS1 --auto"))) +;; (exwm-randr-enable) +;; +;; With above lines, workspace 0 should be assigned to the output named "VGA1", +;; staying at the left of other workspaces on the output "LVDS1". Please refer +;; to xrandr(1) for the configuration of RandR. + +;; References: +;; + RandR (http://www.x.org/archive/X11R7.7/doc/randrproto/randrproto.txt) + +;;; Code: + +(require 'xcb-randr) + +(require 'exwm-core) +(require 'exwm-workspace) + +(declare-function x-get-atom-name "C source code" (VALUE &optional FRAME)) + +(defgroup exwm-randr nil + "RandR." + :group 'exwm) + +(defcustom exwm-randr-refresh-hook nil + "Normal hook run when the RandR module just refreshed." + :type 'hook) + +(defcustom exwm-randr-screen-change-hook nil + "Normal hook run when screen changes." + :type 'hook) + +(defcustom exwm-randr-workspace-monitor-plist nil + "Plist mapping workspaces to monitors. + +In RandR 1.5 a monitor is a rectangle region decoupled from the physical +size of screens, and can be identified with `xrandr --listmonitors' (name of +the primary monitor is prefixed with an `*'). When no monitor is created it +automatically fallback to RandR 1.2 output which represents the physical +screen size. RandR 1.5 monitors can be created with `xrandr --setmonitor'. +For example, to split an output (`LVDS-1') of size 1280x800 into two +side-by-side monitors one could invoke (the digits after `/' are size in mm) + + xrandr --setmonitor *LVDS-1-L 640/135x800/163+0+0 LVDS-1 + xrandr --setmonitor LVDS-1-R 640/135x800/163+640+0 none + +If a monitor is not active, the workspaces mapped to it are displayed on the +primary monitor until it becomes active (if ever). Unspecified workspaces +are all mapped to the primary monitor. For example, with the following +setting workspace other than 1 and 3 would always be displayed on the +primary monitor where workspace 1 and 3 would be displayed on their +corresponding monitors whenever the monitors are active. + + \\='(1 \"HDMI-1\" 3 \"DP-1\")" + :type '(plist :key-type integer :value-type string)) + +(defvar exwm-randr--last-timestamp 0 "Used for debouncing events.") + +(defvar exwm-randr--prev-screen-change-seqnum nil + "The most recent ScreenChangeNotify sequence number.") + +(defvar exwm-randr--compatibility-mode nil + "Non-nil when the server does not support RandR 1.5 protocol.") + +(defun exwm-randr--get-monitors () + "Get RandR 1.5 monitors." + (exwm--log) + (let (monitor-name geometry monitor-geometry-alist primary-monitor) + (with-slots (timestamp monitors) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:randr:GetMonitors + :window exwm--root + :get-active 1)) + (when (> timestamp exwm-randr--last-timestamp) + (setq exwm-randr--last-timestamp timestamp)) + (dolist (monitor monitors) + (with-slots (name primary x y width height) monitor + (setq monitor-name (x-get-atom-name name) + geometry (make-instance 'xcb:RECTANGLE + :x x + :y y + :width width + :height height) + monitor-geometry-alist (cons (cons monitor-name geometry) + monitor-geometry-alist)) + (exwm--log "%s: %sx%s+%s+%s" monitor-name x y width height) + ;; Save primary monitor when available (fallback to the first one). + (when (or (/= 0 primary) + (not primary-monitor)) + (setq primary-monitor monitor-name))))) + (exwm--log "Primary monitor: %s" primary-monitor) + (list primary-monitor monitor-geometry-alist + (exwm-randr--get-monitor-alias primary-monitor + monitor-geometry-alist)))) + +(defun exwm-randr--get-outputs () + "Get RandR 1.2 outputs. + +Only used when RandR 1.5 is not supported by the server." + (exwm--log) + (let (output-name geometry output-geometry-alist primary-output) + (with-slots (config-timestamp outputs) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:randr:GetScreenResourcesCurrent + :window exwm--root)) + (when (> config-timestamp exwm-randr--last-timestamp) + (setq exwm-randr--last-timestamp config-timestamp)) + (dolist (output outputs) + (with-slots (crtc connection name) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:randr:GetOutputInfo + :output output + :config-timestamp config-timestamp)) + (when (and (= connection xcb:randr:Connection:Connected) + (/= crtc 0)) + (with-slots (x y width height) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:randr:GetCrtcInfo + :crtc crtc + :config-timestamp config-timestamp)) + (setq output-name (decode-coding-string + (apply #'unibyte-string name) 'utf-8) + geometry (make-instance 'xcb:RECTANGLE + :x x + :y y + :width width + :height height) + output-geometry-alist (cons (cons output-name geometry) + output-geometry-alist)) + (exwm--log "%s: %sx%s+%s+%s" output-name x y width height) + ;; The primary output is the first one. + (unless primary-output + (setq primary-output output-name))))))) + (exwm--log "Primary output: %s" primary-output) + (list primary-output output-geometry-alist + (exwm-randr--get-monitor-alias primary-output + output-geometry-alist)))) + +(defun exwm-randr--get-monitor-alias (primary-monitor monitor-geometry-alist) + "Generate monitor aliases using PRIMARY-MONITOR MONITOR-GEOMETRY-ALIST. + +In a mirroring setup some monitors overlap and should be treated as one." + (let (monitor-position-alist monitor-alias-alist monitor-name geometry) + (setq monitor-position-alist (with-slots (x y) + (cdr (assoc primary-monitor + monitor-geometry-alist)) + (list (cons primary-monitor (vector x y))))) + (setq monitor-alias-alist (list (cons primary-monitor primary-monitor))) + (dolist (pair monitor-geometry-alist) + (setq monitor-name (car pair) + geometry (cdr pair)) + (unless (assoc monitor-name monitor-alias-alist) + (let* ((position (vector (slot-value geometry 'x) + (slot-value geometry 'y))) + (alias (car (rassoc position monitor-position-alist)))) + (if alias + (setq monitor-alias-alist (cons (cons monitor-name alias) + monitor-alias-alist)) + (setq monitor-position-alist (cons (cons monitor-name position) + monitor-position-alist) + monitor-alias-alist (cons (cons monitor-name monitor-name) + monitor-alias-alist)))))) + monitor-alias-alist)) + +;;;###autoload +(defun exwm-randr-refresh () + "Refresh workspaces according to the updated RandR info." + (interactive) + (exwm--log) + (let* ((result (if exwm-randr--compatibility-mode + (exwm-randr--get-outputs) + (exwm-randr--get-monitors))) + (primary-monitor (elt result 0)) + (monitor-geometry-alist (elt result 1)) + (monitor-alias-alist (elt result 2)) + container-monitor-alist container-frame-alist) + (when (and primary-monitor monitor-geometry-alist) + (when exwm-workspace--fullscreen-frame-count + ;; Not all workspaces are fullscreen; reset this counter. + (setq exwm-workspace--fullscreen-frame-count 0)) + (dotimes (i (exwm-workspace--count)) + (let* ((monitor (plist-get exwm-randr-workspace-monitor-plist i)) + (geometry (cdr (assoc monitor monitor-geometry-alist))) + (frame (elt exwm-workspace--list i)) + (container (frame-parameter frame 'exwm-container))) + (if geometry + ;; Unify monitor names in case it's a mirroring setup. + (setq monitor (cdr (assoc monitor monitor-alias-alist))) + ;; Missing monitors fallback to the primary one. + (setq monitor primary-monitor + geometry (cdr (assoc primary-monitor + monitor-geometry-alist)))) + (setq container-monitor-alist (nconc + `((,container . ,(intern monitor))) + container-monitor-alist) + container-frame-alist (nconc `((,container . ,frame)) + container-frame-alist)) + (set-frame-parameter frame 'exwm-randr-monitor monitor) + (set-frame-parameter frame 'exwm-geometry geometry))) + ;; Update workareas. + (exwm-workspace--update-workareas) + ;; Resize workspace. + (dolist (f exwm-workspace--list) + (exwm-workspace--set-fullscreen f)) + (xcb:flush exwm--connection) + ;; Raise the minibuffer if it's active. + (when (and (active-minibuffer-window) + (exwm-workspace--minibuffer-own-frame-p)) + (exwm-workspace--show-minibuffer)) + ;; Set _NET_DESKTOP_GEOMETRY. + (exwm-workspace--set-desktop-geometry) + ;; Update active/inactive workspaces. + (dolist (w exwm-workspace--list) + (exwm-workspace--set-active w nil)) + ;; Mark the workspace on the top of each monitor as active. + (dolist (xwin + (reverse + (slot-value (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:QueryTree + :window exwm--root)) + 'children))) + (let ((monitor (cdr (assq xwin container-monitor-alist)))) + (when monitor + (setq container-monitor-alist + (rassq-delete-all monitor container-monitor-alist)) + (exwm-workspace--set-active (cdr (assq xwin container-frame-alist)) + t)))) + (xcb:flush exwm--connection) + (run-hooks 'exwm-randr-refresh-hook)))) + +(defun exwm-randr--on-ScreenChangeNotify (data _synthetic) + "Handle `ScreenChangeNotify' event. + +Run `exwm-randr-screen-change-hook' (usually user scripts to configure RandR)." + (exwm--log) + (let ((evt (make-instance 'xcb:randr:ScreenChangeNotify))) + (xcb:unmarshal evt data) + (let ((seqnum (slot-value evt '~sequence))) + (unless (equal seqnum exwm-randr--prev-screen-change-seqnum) + (setq exwm-randr--prev-screen-change-seqnum seqnum) + (run-hooks 'exwm-randr-screen-change-hook))))) + +(defun exwm-randr--on-Notify (data _synthetic) + "Handle `CrtcChangeNotify' and `OutputChangeNotify' events. + +Refresh when any CRTC/output changes." + (exwm--log) + (let ((evt (make-instance 'xcb:randr:Notify)) + notify) + (xcb:unmarshal evt data) + (with-slots (subCode u) evt + (cl-case subCode + (xcb:randr:Notify:CrtcChange + (setq notify (slot-value u 'cc))) + (xcb:randr:Notify:OutputChange + (setq notify (slot-value u 'oc)))) + (when notify + (with-slots (timestamp) notify + (when (> timestamp exwm-randr--last-timestamp) + (exwm-randr-refresh) + (setq exwm-randr--last-timestamp timestamp))))))) + +(defun exwm-randr--on-ConfigureNotify (data _synthetic) + "Handle `ConfigureNotify' event. + +Refresh when any RandR 1.5 monitor changes." + (exwm--log) + (let ((evt (make-instance 'xcb:ConfigureNotify))) + (xcb:unmarshal evt data) + (with-slots (window) evt + (when (eq window exwm--root) + (exwm-randr-refresh))))) + +(defun exwm-randr--init () + "Initialize RandR extension and EXWM RandR module." + (exwm--log) + (when (= 0 (slot-value (xcb:get-extension-data exwm--connection 'xcb:randr) + 'present)) + (error "[EXWM] RandR extension is not supported by the server")) + (with-slots (major-version minor-version) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:randr:QueryVersion + :major-version 1 :minor-version 5)) + (cond ((and (= major-version 1) (= minor-version 5)) + (setq exwm-randr--compatibility-mode nil)) + ((and (= major-version 1) (>= minor-version 2)) + (setq exwm-randr--compatibility-mode t)) + (t + (error "[EXWM] The server only support RandR version up to %d.%d" + major-version minor-version))) + ;; External monitor(s) may already be connected. + (run-hooks 'exwm-randr-screen-change-hook) + (exwm-randr-refresh) + ;; Listen for `ScreenChangeNotify' to notify external tools to + ;; configure RandR and `CrtcChangeNotify/OutputChangeNotify' to + ;; refresh the workspace layout. + (xcb:+event exwm--connection 'xcb:randr:ScreenChangeNotify + #'exwm-randr--on-ScreenChangeNotify) + (xcb:+event exwm--connection 'xcb:randr:Notify + #'exwm-randr--on-Notify) + (xcb:+event exwm--connection 'xcb:ConfigureNotify + #'exwm-randr--on-ConfigureNotify) + (xcb:+request exwm--connection + (make-instance 'xcb:randr:SelectInput + :window exwm--root + :enable (logior + xcb:randr:NotifyMask:ScreenChange + xcb:randr:NotifyMask:CrtcChange + xcb:randr:NotifyMask:OutputChange))) + (xcb:flush exwm--connection) + (add-hook 'exwm-workspace-list-change-hook #'exwm-randr-refresh)) + ;; Prevent frame parameters introduced by this module from being + ;; saved/restored. + (dolist (i '(exwm-randr-monitor)) + (unless (assq i frameset-filter-alist) + (push (cons i :never) frameset-filter-alist)))) + +(defun exwm-randr--exit () + "Exit the RandR module." + (exwm--log) + (remove-hook 'exwm-workspace-list-change-hook #'exwm-randr-refresh)) + +(defun exwm-randr-enable () + "Enable RandR support for EXWM." + (exwm--log) + (add-hook 'exwm-init-hook #'exwm-randr--init) + (add-hook 'exwm-exit-hook #'exwm-randr--exit)) + + + +(provide 'exwm-randr) + +;;; exwm-randr.el ends here diff --git a/third_party/exwm/exwm-systemtray.el b/third_party/exwm/exwm-systemtray.el new file mode 100644 index 0000000000..9e57dae4eb --- /dev/null +++ b/third_party/exwm/exwm-systemtray.el @@ -0,0 +1,701 @@ +;;; exwm-systemtray.el --- System Tray Module for -*- lexical-binding: t -*- +;;; EXWM + +;; Copyright (C) 2016-2024 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module adds system tray support for EXWM. + +;; To use this module, load and enable it as follows: +;; (require 'exwm-systemtray) +;; (exwm-systemtray-enable) + +;;; Code: + +(require 'xcb-ewmh) +(require 'xcb-icccm) +(require 'xcb-xembed) +(require 'xcb-systemtray) + +(require 'exwm-core) +(require 'exwm-workspace) + +(declare-function exwm-workspace--workarea "exwm-workspace.el" (frame)) + +(defclass exwm-systemtray--icon () + ((width :initarg :width) + (height :initarg :height) + (visible :initarg :visible)) + :documentation "Attributes of a system tray icon.") + +(defclass xcb:systemtray:-ClientMessage + (xcb:icccm:--ClientMessage xcb:ClientMessage) + ((format :initform 32) + (type :initform 'xcb:Atom:MANAGER) + (time :initarg :time :type xcb:TIMESTAMP) ;new slot + (selection :initarg :selection :type xcb:ATOM) ;new slot + (owner :initarg :owner :type xcb:WINDOW)) ;new slot + :documentation "A systemtray client message.") + +(defgroup exwm-systemtray nil + "System tray." + :group 'exwm) + +(defcustom exwm-systemtray-height nil + "System tray height. + +You shall use the default value if using auto-hide minibuffer." + :type 'integer) + +(defcustom exwm-systemtray-icon-gap 2 + "Gap between icons." + :type 'integer) + +(defvar exwm-systemtray--connection nil "The X connection.") + +(defvar exwm-systemtray--embedder-window nil "The embedder window.") +(defvar exwm-systemtray--embedder-window-depth nil + "The embedder window's depth.") + +(defcustom exwm-systemtray-background-color 'workspace-background + "Background color of systemtray. +This should be a color, the symbol `workspace-background' for the background +color of current workspace frame, or the symbol `transparent' for transparent +background. + +Transparent background is not yet supported when Emacs uses 32-bit depth +visual, as reported by `x-display-planes'. The X resource \"Emacs.visualClass: +TrueColor-24\" can be used to force Emacs to use 24-bit depth." + :type '(choice (const :tag "Transparent" transparent) + (const :tag "Frame background" workspace-background) + (color :tag "Color")) + :initialize #'custom-initialize-default + :set (lambda (symbol value) + (when (and (eq value 'transparent) + (not (exwm-systemtray--transparency-supported-p))) + (display-warning 'exwm-systemtray + "Transparent background is not supported yet when \ +using 32-bit depth. Using `workspace-background' instead.") + (setq value 'workspace-background)) + (set-default symbol value) + (when (and exwm-systemtray--connection + exwm-systemtray--embedder-window) + ;; Change the background color for embedder. + (exwm-systemtray--set-background-color) + ;; Unmap & map to take effect immediately. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:UnmapWindow + :window exwm-systemtray--embedder-window)) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:MapWindow + :window exwm-systemtray--embedder-window)) + (xcb:flush exwm-systemtray--connection)))) + +;; GTK icons require at least 16 pixels to show normally. +(defconst exwm-systemtray--icon-min-size 16 "Minimum icon size.") + +(defvar exwm-systemtray--list nil "The icon list.") + +(defvar exwm-systemtray--selection-owner-window nil + "The selection owner window.") + +(defvar xcb:Atom:_NET_SYSTEM_TRAY_S0) + +(defun exwm-systemtray--embed (icon) + "Embed an ICON." + (exwm--log "Try to embed #x%x" icon) + (let ((info (xcb:+request-unchecked+reply exwm-systemtray--connection + (make-instance 'xcb:xembed:get-_XEMBED_INFO + :window icon))) + width* height* visible) + (when info + (exwm--log "Embed #x%x" icon) + (with-slots (width height) + (xcb:+request-unchecked+reply exwm-systemtray--connection + (make-instance 'xcb:GetGeometry :drawable icon)) + (setq height* exwm-systemtray-height + width* (round (* width (/ (float height*) height)))) + (when (< width* exwm-systemtray--icon-min-size) + (setq width* exwm-systemtray--icon-min-size + height* (round (* height (/ (float width*) width))))) + (exwm--log "Resize from %dx%d to %dx%d" + width height width* height*)) + ;; Add this icon to save-set. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ChangeSaveSet + :mode xcb:SetMode:Insert + :window icon)) + ;; Reparent to the embedder. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ReparentWindow + :window icon + :parent exwm-systemtray--embedder-window + :x 0 + ;; Vertically centered. + :y (/ (- exwm-systemtray-height height*) 2))) + ;; Resize the icon. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ConfigureWindow + :window icon + :value-mask (logior xcb:ConfigWindow:Width + xcb:ConfigWindow:Height + xcb:ConfigWindow:BorderWidth) + :width width* + :height height* + :border-width 0)) + ;; Set event mask. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ChangeWindowAttributes + :window icon + :value-mask xcb:CW:EventMask + :event-mask (logior xcb:EventMask:ResizeRedirect + xcb:EventMask:KeyPress + xcb:EventMask:PropertyChange))) + ;; Grab all keys and forward them to Emacs frame. + (unless (exwm-workspace--minibuffer-own-frame-p) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:GrabKey + :owner-events 0 + :grab-window icon + :modifiers xcb:ModMask:Any + :key xcb:Grab:Any + :pointer-mode xcb:GrabMode:Async + :keyboard-mode xcb:GrabMode:Async))) + (setq visible (slot-value info 'flags)) + (if visible + (setq visible + (/= 0 (logand (slot-value info 'flags) xcb:xembed:MAPPED))) + ;; Default to visible. + (setq visible t)) + (when visible + (exwm--log "Map the window") + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:MapWindow :window icon))) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:xembed:SendEvent + :destination icon + :event + (xcb:marshal + (make-instance 'xcb:xembed:EMBEDDED-NOTIFY + :window icon + :time xcb:Time:CurrentTime + :embedder + exwm-systemtray--embedder-window + :version 0) + exwm-systemtray--connection))) + (push `(,icon . ,(make-instance 'exwm-systemtray--icon + :width width* + :height height* + :visible visible)) + exwm-systemtray--list) + (exwm-systemtray--refresh)))) + +(defun exwm-systemtray--unembed (icon) + "Unembed an ICON." + (exwm--log "Unembed #x%x" icon) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:UnmapWindow :window icon)) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ReparentWindow + :window icon + :parent exwm--root + :x 0 :y 0)) + (setq exwm-systemtray--list + (assq-delete-all icon exwm-systemtray--list)) + (exwm-systemtray--refresh)) + +(defun exwm-systemtray--refresh () + "Refresh the system tray." + (exwm--log) + ;; Make sure to redraw the embedder. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:UnmapWindow + :window exwm-systemtray--embedder-window)) + (let ((x exwm-systemtray-icon-gap) + map) + (dolist (pair exwm-systemtray--list) + (when (slot-value (cdr pair) 'visible) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ConfigureWindow + :window (car pair) + :value-mask xcb:ConfigWindow:X + :x x)) + (setq x (+ x (slot-value (cdr pair) 'width) + exwm-systemtray-icon-gap)) + (setq map t))) + (let ((workarea (exwm-workspace--workarea exwm-workspace-current-index))) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ConfigureWindow + :window exwm-systemtray--embedder-window + :value-mask (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Width) + :x (- (slot-value workarea 'width) x) + :width x))) + (when map + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:MapWindow + :window exwm-systemtray--embedder-window)))) + (xcb:flush exwm-systemtray--connection)) + +(defun exwm-systemtray--refresh-background-color (&optional remap) + "Refresh background color after theme change or workspace switch. +If REMAP is not nil, map and unmap the embedder window so that the background is +redrawn." + ;; Only `workspace-background' is dependent on current theme and workspace. + (when (eq 'workspace-background exwm-systemtray-background-color) + (exwm-systemtray--set-background-color) + (when remap + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:UnmapWindow + :window exwm-systemtray--embedder-window)) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:MapWindow + :window exwm-systemtray--embedder-window)) + (xcb:flush exwm-systemtray--connection)))) + +(defun exwm-systemtray--set-background-color () + "Change the background color of the embedder. +The color is set according to `exwm-systemtray-background-color'. + +Note that this function does not change the current contents of the embedder +window; unmap & map are necessary for the background color to take effect." + (when (and exwm-systemtray--connection + exwm-systemtray--embedder-window) + (let* ((color (cl-case exwm-systemtray-background-color + ((transparent nil) ; nil means transparent as well + (if (exwm-systemtray--transparency-supported-p) + nil + (message "%s" "[EXWM] system tray does not support \ +`transparent' background; using `workspace-background' instead") + (face-background 'default exwm-workspace--current))) + (workspace-background + (face-background 'default exwm-workspace--current)) + (t exwm-systemtray-background-color))) + (background-pixel (exwm--color->pixel color))) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ChangeWindowAttributes + :window exwm-systemtray--embedder-window + ;; Either-or. A `background-pixel' of nil + ;; means simulate transparency. We use + ;; `xcb:CW:BackPixmap' together with + ;; `xcb:BackPixmap:ParentRelative' do that, + ;; but this only works when the parent + ;; window's visual (Emacs') has the same + ;; visual depth. + :value-mask (if background-pixel + xcb:CW:BackPixel + xcb:CW:BackPixmap) + ;; Due to the :value-mask above, + ;; :background-pixmap only takes effect when + ;; `transparent' is requested and supported + ;; (visual depth of Emacs and of system tray + ;; are equal). Setting + ;; `xcb:BackPixmap:ParentRelative' when + ;; that's not the case would produce an + ;; `xcb:Match' error. + :background-pixmap xcb:BackPixmap:ParentRelative + :background-pixel background-pixel))))) + +(defun exwm-systemtray--transparency-supported-p () + "Check whether transparent background is supported. +EXWM system tray supports transparency when the visual depth of the system tray +window matches that of Emacs. The visual depth of the system tray window is the +default visual depth of the display. + +Sections \"Visual and background pixmap handling\" and +\"_NET_SYSTEM_TRAY_VISUAL\" of the System Tray Protocol Specification +\(https://specifications.freedesktop.org/systemtray-spec/systemtray-spec-latest.html#visuals) +indicate how to support actual transparency." + (let ((planes (x-display-planes))) + (if exwm-systemtray--embedder-window-depth + (= planes exwm-systemtray--embedder-window-depth) + (<= planes 24)))) + +(defun exwm-systemtray--on-DestroyNotify (data _synthetic) + "Unembed icons on DestroyNotify. +Argument DATA contains the raw event data." + (exwm--log) + (let ((obj (make-instance 'xcb:DestroyNotify))) + (xcb:unmarshal obj data) + (with-slots (window) obj + (when (assoc window exwm-systemtray--list) + (exwm-systemtray--unembed window))))) + +(defun exwm-systemtray--on-ReparentNotify (data _synthetic) + "Unembed icons on ReparentNotify. +Argument DATA contains the raw event data." + (exwm--log) + (let ((obj (make-instance 'xcb:ReparentNotify))) + (xcb:unmarshal obj data) + (with-slots (window parent) obj + (when (and (/= parent exwm-systemtray--embedder-window) + (assoc window exwm-systemtray--list)) + (exwm-systemtray--unembed window))))) + +(defun exwm-systemtray--on-ResizeRequest (data _synthetic) + "Resize the tray icon on ResizeRequest. +Argument DATA contains the raw event data." + (exwm--log) + (let ((obj (make-instance 'xcb:ResizeRequest)) + attr) + (xcb:unmarshal obj data) + (with-slots (window width height) obj + (when (setq attr (cdr (assoc window exwm-systemtray--list))) + (with-slots ((width* width) + (height* height)) + attr + (setq height* exwm-systemtray-height + width* (round (* width (/ (float height*) height)))) + (when (< width* exwm-systemtray--icon-min-size) + (setq width* exwm-systemtray--icon-min-size + height* (round (* height (/ (float width*) width))))) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ConfigureWindow + :window window + :value-mask (logior xcb:ConfigWindow:Y + xcb:ConfigWindow:Width + xcb:ConfigWindow:Height) + ;; Vertically centered. + :y (/ (- exwm-systemtray-height height*) 2) + :width width* + :height height*))) + (exwm-systemtray--refresh))))) + +(defun exwm-systemtray--on-PropertyNotify (data _synthetic) + "Map/Unmap the tray icon on PropertyNotify. +Argument DATA contains the raw event data." + (exwm--log) + (let ((obj (make-instance 'xcb:PropertyNotify)) + attr info visible) + (xcb:unmarshal obj data) + (with-slots (window atom state) obj + (when (and (eq state xcb:Property:NewValue) + (eq atom xcb:Atom:_XEMBED_INFO) + (setq attr (cdr (assoc window exwm-systemtray--list)))) + (setq info (xcb:+request-unchecked+reply exwm-systemtray--connection + (make-instance 'xcb:xembed:get-_XEMBED_INFO + :window window))) + (when info + (setq visible (/= 0 (logand (slot-value info 'flags) + xcb:xembed:MAPPED))) + (exwm--log "#x%x visible? %s" window visible) + (if visible + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:MapWindow :window window)) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:UnmapWindow :window window))) + (setf (slot-value attr 'visible) visible) + (exwm-systemtray--refresh)))))) + +(defun exwm-systemtray--on-ClientMessage (data _synthetic) + "Handle client messages. +Argument DATA contains the raw event data." + (let ((obj (make-instance 'xcb:ClientMessage)) + opcode data32) + (xcb:unmarshal obj data) + (with-slots (window type data) obj + (when (eq type xcb:Atom:_NET_SYSTEM_TRAY_OPCODE) + (setq data32 (slot-value data 'data32) + opcode (elt data32 1)) + (exwm--log "opcode: %s" opcode) + (cond ((= opcode xcb:systemtray:opcode:REQUEST-DOCK) + (unless (assoc (elt data32 2) exwm-systemtray--list) + (exwm-systemtray--embed (elt data32 2)))) + ;; Not implemented (rarely used nowadays). + ((or (= opcode xcb:systemtray:opcode:BEGIN-MESSAGE) + (= opcode xcb:systemtray:opcode:CANCEL-MESSAGE))) + (t + (exwm--log "Unknown opcode message: %s" obj))))))) + +(defun exwm-systemtray--on-KeyPress (data _synthetic) + "Forward all KeyPress events to Emacs frame. +Argument DATA contains the raw event data." + (exwm--log) + ;; This function is only executed when there's no autohide minibuffer, + ;; a workspace frame has the input focus and the pointer is over a + ;; tray icon. + (let ((dest (frame-parameter (selected-frame) 'exwm-outer-id)) + (obj (make-instance 'xcb:KeyPress))) + (xcb:unmarshal obj data) + (setf (slot-value obj 'event) dest) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:SendEvent + :propagate 0 + :destination dest + :event-mask xcb:EventMask:NoEvent + :event (xcb:marshal obj exwm-systemtray--connection)))) + (xcb:flush exwm-systemtray--connection)) + +(defun exwm-systemtray--on-workspace-switch () + "Reparent/Refresh the system tray in `exwm-workspace-switch-hook'." + (exwm--log) + (unless (exwm-workspace--minibuffer-own-frame-p) + (exwm-workspace--update-offsets) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ReparentWindow + :window exwm-systemtray--embedder-window + :parent (string-to-number + (frame-parameter exwm-workspace--current + 'window-id)) + :x 0 + :y (- (slot-value (exwm-workspace--workarea + exwm-workspace-current-index) + 'height) + exwm-workspace--frame-y-offset + exwm-systemtray-height)))) + (exwm-systemtray--refresh-background-color) + (exwm-systemtray--refresh)) + +(defun exwm-systemtray--on-theme-change (_theme) + "Refresh system tray upon theme change." + (exwm-systemtray--refresh-background-color 'remap)) + +(defun exwm-systemtray--refresh-all () + "Reposition/Refresh the system tray." + (exwm--log) + (unless (exwm-workspace--minibuffer-own-frame-p) + (exwm-workspace--update-offsets) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ConfigureWindow + :window exwm-systemtray--embedder-window + :value-mask xcb:ConfigWindow:Y + :y (- (slot-value (exwm-workspace--workarea + exwm-workspace-current-index) + 'height) + exwm-workspace--frame-y-offset + exwm-systemtray-height)))) + (exwm-systemtray--refresh)) + +(cl-defun exwm-systemtray--init () + "Initialize system tray module." + (exwm--log) + (cl-assert (not exwm-systemtray--connection)) + (cl-assert (not exwm-systemtray--list)) + (cl-assert (not exwm-systemtray--selection-owner-window)) + (cl-assert (not exwm-systemtray--embedder-window)) + (unless exwm-systemtray-height + (setq exwm-systemtray-height (max exwm-systemtray--icon-min-size + (with-selected-window (minibuffer-window) + (line-pixel-height))))) + ;; Create a new connection. + (setq exwm-systemtray--connection (xcb:connect)) + (set-process-query-on-exit-flag (slot-value exwm-systemtray--connection + 'process) + nil) + ;; Initialize XELB modules. + (xcb:xembed:init exwm-systemtray--connection t) + (xcb:systemtray:init exwm-systemtray--connection t) + ;; Acquire the manager selection _NET_SYSTEM_TRAY_S0. + (with-slots (owner) + (xcb:+request-unchecked+reply exwm-systemtray--connection + (make-instance 'xcb:GetSelectionOwner + :selection xcb:Atom:_NET_SYSTEM_TRAY_S0)) + (when (/= owner xcb:Window:None) + (xcb:disconnect exwm-systemtray--connection) + (setq exwm-systemtray--connection nil) + (warn "[EXWM] Other system tray detected") + (cl-return-from exwm-systemtray--init))) + (let ((id (xcb:generate-id exwm-systemtray--connection))) + (setq exwm-systemtray--selection-owner-window id) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:CreateWindow + :depth 0 + :wid id + :parent exwm--root + :x 0 + :y 0 + :width 1 + :height 1 + :border-width 0 + :class xcb:WindowClass:InputOnly + :visual 0 + :value-mask xcb:CW:OverrideRedirect + :override-redirect 1)) + ;; Get the selection ownership. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:SetSelectionOwner + :owner id + :selection xcb:Atom:_NET_SYSTEM_TRAY_S0 + :time xcb:Time:CurrentTime)) + ;; Send a client message to announce the selection. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:SendEvent + :propagate 0 + :destination exwm--root + :event-mask xcb:EventMask:StructureNotify + :event (xcb:marshal + (make-instance 'xcb:systemtray:-ClientMessage + :window exwm--root + :time xcb:Time:CurrentTime + :selection + xcb:Atom:_NET_SYSTEM_TRAY_S0 + :owner id) + exwm-systemtray--connection))) + ;; Set _NET_WM_NAME. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window id + :data "EXWM: exwm-systemtray--selection-owner-window")) + ;; Set the _NET_SYSTEM_TRAY_ORIENTATION property. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:xembed:set-_NET_SYSTEM_TRAY_ORIENTATION + :window id + :data xcb:systemtray:ORIENTATION:HORZ))) + ;; Create the embedder. + (let ((id (xcb:generate-id exwm-systemtray--connection)) + frame parent embedder-depth embedder-visual embedder-colormap y) + (setq exwm-systemtray--embedder-window id) + (if (exwm-workspace--minibuffer-own-frame-p) + (setq frame exwm-workspace--minibuffer + y (if (>= (line-pixel-height) exwm-systemtray-height) + ;; Bottom aligned. + (- (line-pixel-height) exwm-systemtray-height) + ;; Vertically centered. + (/ (- (line-pixel-height) exwm-systemtray-height) 2))) + (exwm-workspace--update-offsets) + (setq frame exwm-workspace--current + ;; Bottom aligned. + y (- (slot-value (exwm-workspace--workarea + exwm-workspace-current-index) + 'height) + exwm-workspace--frame-y-offset + exwm-systemtray-height))) + (setq parent (string-to-number (frame-parameter frame 'window-id))) + ;; Use default depth, visual and colormap (from root window), instead of + ;; Emacs frame's. See Section "Visual and background pixmap handling" in + ;; "System Tray Protocol Specification 0.3". + (let* ((vdc (exwm--get-visual-depth-colormap exwm-systemtray--connection + exwm--root))) + (setq embedder-visual (car vdc)) + (setq embedder-depth (cadr vdc)) + (setq embedder-colormap (caddr vdc))) + ;; Note down the embedder window's depth. It will be used to check whether + ;; we can use xcb:BackPixmap:ParentRelative to emulate transparency. + (setq exwm-systemtray--embedder-window-depth embedder-depth) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:CreateWindow + :depth embedder-depth + :wid id + :parent parent + :x 0 + :y y + :width 1 + :height exwm-systemtray-height + :border-width 0 + :class xcb:WindowClass:InputOutput + :visual embedder-visual + :colormap embedder-colormap + :value-mask (logior xcb:CW:BorderPixel + xcb:CW:Colormap + xcb:CW:EventMask) + :border-pixel 0 + :event-mask xcb:EventMask:SubstructureNotify)) + (exwm-systemtray--set-background-color) + ;; Set _NET_WM_NAME. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window id + :data "EXWM: exwm-systemtray--embedder-window")) + ;; Set _NET_WM_WINDOW_TYPE. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ewmh:set-_NET_WM_WINDOW_TYPE + :window id + :data (vector xcb:Atom:_NET_WM_WINDOW_TYPE_DOCK))) + ;; Set _NET_SYSTEM_TRAY_VISUAL. + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:xembed:set-_NET_SYSTEM_TRAY_VISUAL + :window exwm-systemtray--selection-owner-window + :data embedder-visual))) + (xcb:flush exwm-systemtray--connection) + ;; Attach event listeners. + (xcb:+event exwm-systemtray--connection 'xcb:DestroyNotify + #'exwm-systemtray--on-DestroyNotify) + (xcb:+event exwm-systemtray--connection 'xcb:ReparentNotify + #'exwm-systemtray--on-ReparentNotify) + (xcb:+event exwm-systemtray--connection 'xcb:ResizeRequest + #'exwm-systemtray--on-ResizeRequest) + (xcb:+event exwm-systemtray--connection 'xcb:PropertyNotify + #'exwm-systemtray--on-PropertyNotify) + (xcb:+event exwm-systemtray--connection 'xcb:ClientMessage + #'exwm-systemtray--on-ClientMessage) + (unless (exwm-workspace--minibuffer-own-frame-p) + (xcb:+event exwm-systemtray--connection 'xcb:KeyPress + #'exwm-systemtray--on-KeyPress)) + ;; Add hook to move/reparent the embedder. + (add-hook 'exwm-workspace-switch-hook #'exwm-systemtray--on-workspace-switch) + (add-hook 'exwm-workspace--update-workareas-hook + #'exwm-systemtray--refresh-all) + ;; Add hook to update background colors. + (add-hook 'enable-theme-functions #'exwm-systemtray--on-theme-change) + (add-hook 'disable-theme-functions #'exwm-systemtray--on-theme-change) + (add-hook 'menu-bar-mode-hook #'exwm-systemtray--refresh-all) + (add-hook 'tool-bar-mode-hook #'exwm-systemtray--refresh-all) + (when (boundp 'exwm-randr-refresh-hook) + (add-hook 'exwm-randr-refresh-hook #'exwm-systemtray--refresh-all)) + ;; The struts can be updated already. + (when exwm-workspace--workareas + (exwm-systemtray--refresh-all))) + +(defun exwm-systemtray--exit () + "Exit the systemtray module." + (exwm--log) + (when exwm-systemtray--connection + (when (slot-value exwm-systemtray--connection 'connected) + ;; Hide & reparent out the embedder before disconnection to prevent + ;; embedded icons from being reparented to an Emacs frame (which is the + ;; parent of the embedder). + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:UnmapWindow + :window exwm-systemtray--embedder-window)) + (xcb:+request exwm-systemtray--connection + (make-instance 'xcb:ReparentWindow + :window exwm-systemtray--embedder-window + :parent exwm--root + :x 0 + :y 0)) + (xcb:disconnect exwm-systemtray--connection)) + (setq exwm-systemtray--connection nil + exwm-systemtray--list nil + exwm-systemtray--selection-owner-window nil + exwm-systemtray--embedder-window nil + exwm-systemtray--embedder-window-depth nil) + (remove-hook 'exwm-workspace-switch-hook + #'exwm-systemtray--on-workspace-switch) + (remove-hook 'exwm-workspace--update-workareas-hook + #'exwm-systemtray--refresh-all) + (remove-hook 'enable-theme-functions #'exwm-systemtray--on-theme-change) + (remove-hook 'disable-theme-functions #'exwm-systemtray--on-theme-change) + (remove-hook 'menu-bar-mode-hook #'exwm-systemtray--refresh-all) + (remove-hook 'tool-bar-mode-hook #'exwm-systemtray--refresh-all) + (when (boundp 'exwm-randr-refresh-hook) + (remove-hook 'exwm-randr-refresh-hook #'exwm-systemtray--refresh-all)))) + +(defun exwm-systemtray-enable () + "Enable system tray support for EXWM." + (exwm--log) + (add-hook 'exwm-init-hook #'exwm-systemtray--init) + (add-hook 'exwm-exit-hook #'exwm-systemtray--exit)) + + + +(provide 'exwm-systemtray) + +;;; exwm-systemtray.el ends here diff --git a/third_party/exwm/exwm-workspace.el b/third_party/exwm/exwm-workspace.el new file mode 100644 index 0000000000..89be697159 --- /dev/null +++ b/third_party/exwm/exwm-workspace.el @@ -0,0 +1,1768 @@ +;;; exwm-workspace.el --- Workspace Module for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 1015-2024 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module adds workspace support for EXWM. + +;;; Code: + +(require 'server) + +(require 'exwm-core) + +(defgroup exwm-workspace nil + "Workspace." + :group 'exwm) + +(defcustom exwm-workspace-switch-hook nil + "Normal hook run after switching workspace." + :type 'hook) + +(defcustom exwm-workspace-list-change-hook nil + "Normal hook run when the workspace list is changed. +This happens when a workspace is added, deleted, moved, etc." + :type 'hook) + +(defcustom exwm-workspace-show-all-buffers nil + "Non-nil to show buffers on other workspaces." + :type 'boolean) + +(defcustom exwm-workspace-warp-cursor nil + "Non-nil to warp cursor automatically after workspace switch." + :type 'boolean) + +(defcustom exwm-workspace-number 1 + "Initial number of workspaces." + :type 'integer) + +(defcustom exwm-workspace-index-map #'number-to-string + "Function for mapping a workspace index to a string for display. + +By default `number-to-string' is applied which yields 0 1 2 ... ." + :type 'function) + +(defcustom exwm-workspace-minibuffer-position nil + "Position of the minibuffer frame. + +A restart is required for this change to take effect." + :type '(choice (const :tag "Bottom (fixed)" nil) + (const :tag "Bottom (auto-hide)" bottom) + (const :tag "Top (auto-hide)" top))) + +(defcustom exwm-workspace-display-echo-area-timeout 1 + "Timeout for displaying echo area." + :type 'integer) + +(defcustom exwm-workspace-switch-create-limit 10 + "Number of workspaces `exwm-workspace-switch-create' is allowed to create." + :type 'integer) + +(defvar exwm-workspace-current-index 0 "Index of current active workspace.") + +(defvar exwm-workspace--attached-minibuffer-height 0 + "Height (in pixel) of the attached minibuffer. + +If the minibuffer is detached, this value is 0.") + +(defvar exwm-workspace--create-silently nil + "When non-nil workspaces are created in the background (not switched to). + +Please manually run the hook `exwm-workspace-list-change-hook' afterwards.") + +(defvar exwm-workspace--current nil "Current active workspace.") + +(defvar exwm-workspace--display-echo-area-timer nil + "Timer for auto-hiding echo area.") + +(defvar exwm-workspace--id-struts-alist nil "Alist of X window and struts.") + +(defvar exwm-workspace--fullscreen-frame-count 0 + "Count the fullscreen workspace frames.") + +(defvar exwm-workspace--list nil "List of all workspaces (Emacs frames).") + +(defvar exwm-workspace--minibuffer nil + "The minibuffer frame shared among all frames.") + +(defvar exwm-workspace--original-handle-focus-in + (symbol-function #'handle-focus-in)) +(defvar exwm-workspace--original-handle-focus-out + (symbol-function #'handle-focus-out)) + +(defvar exwm-workspace--prompt-add-allowed nil + "Non-nil to allow adding workspace from the prompt.") + +(defvar exwm-workspace--prompt-delete-allowed nil + "Non-nil to allow deleting workspace from the prompt.") + +(defvar exwm-workspace--struts nil "Areas occupied by struts.") + +(defvar exwm-workspace--switch-history nil + "History for `read-from-minibuffer' to interactively switch workspace.") + +(defvar exwm-workspace--switch-history-outdated nil + "Non-nil to indicate `exwm-workspace--switch-history' is outdated.") + +(defvar exwm-workspace--timer nil "Timer used to track echo area changes.") + +(defvar exwm-workspace--update-workareas-hook nil + "Normal hook run when workareas get updated.") + +(defvar exwm-workspace--workareas nil "Workareas (struts excluded).") + +(defvar exwm-workspace--frame-y-offset 0 + "Offset between Emacs inner & outer frame in Y.") +(defvar exwm-workspace--window-y-offset 0 + "Offset between Emacs first window & outer frame in Y.") + +(defvar exwm-input--during-command) +(defvar exwm-input--event-hook) +(defvar exwm-layout-show-all-buffers) +(defvar exwm-manage--desktop) +(declare-function exwm-input--on-buffer-list-update "exwm-input.el" ()) +(declare-function exwm-layout--fullscreen-p "exwm-layout.el" ()) +(declare-function exwm-layout--hide "exwm-layout.el" (id)) +(declare-function exwm-layout--other-buffer-predicate "exwm-layout.el" + (buffer)) +(declare-function exwm-layout--refresh "exwm-layout.el") +(declare-function exwm-layout--show "exwm-layout.el" (id &optional window)) + +(defsubst exwm-workspace--position (frame) + "Retrieve index of given FRAME in workspace list. +NIL if FRAME is not a workspace." + (declare (indent defun)) + (cl-position frame exwm-workspace--list)) + +(defsubst exwm-workspace--count () + "Retrieve total number of workspaces." + (length exwm-workspace--list)) + +(defsubst exwm-workspace--workspace-p (frame) + "Return t if FRAME is a workspace." + (declare (indent defun)) + (memq frame exwm-workspace--list)) + +(defsubst exwm-workspace--workarea (frame) + "Return workarea corresponding to FRAME. +FRAME may be either a workspace frame or a workspace position." + (declare (indent defun)) + (elt exwm-workspace--workareas + (if (integerp frame) + frame + (exwm-workspace--position frame)))) + +(defvar exwm-workspace--switch-map nil + "Keymap used for interactively selecting workspace.") + +(defun exwm-workspace--init-switch-map () + "Initialize variable `exwm-workspace--switch-map'." + (let ((map (make-sparse-keymap))) + (define-key map [t] (lambda () (interactive))) + (define-key map "+" #'exwm-workspace--prompt-add) + (define-key map "-" #'exwm-workspace--prompt-delete) + (dotimes (i 10) + (define-key map (int-to-string i) + #'exwm-workspace--switch-map-nth-prefix)) + (unless (eq exwm-workspace-index-map #'number-to-string) + ;; Add extra (and possibly override) keys for selecting workspace. + (dotimes (i 10) + (let ((key (funcall exwm-workspace-index-map i))) + (when (and (stringp key) + (= (length key) 1) + (<= 0 (elt key 0) 127)) + (define-key map key + (lambda () + (interactive) + (exwm-workspace--switch-map-select-nth i))))))) + (define-key map "\C-a" (lambda () (interactive) (goto-history-element 1))) + (define-key map "\C-e" (lambda () + (interactive) + (goto-history-element (exwm-workspace--count)))) + (define-key map "\C-g" #'abort-recursive-edit) + (define-key map "\C-]" #'abort-recursive-edit) + (define-key map "\C-j" #'exit-minibuffer) + ;; (define-key map "\C-m" #'exit-minibuffer) ;not working + (define-key map [return] #'exit-minibuffer) + (define-key map " " #'exit-minibuffer) + (define-key map "\C-f" #'previous-history-element) + (define-key map "\C-b" #'next-history-element) + ;; Alternative keys + (define-key map [right] #'previous-history-element) + (define-key map [left] #'next-history-element) + (setq exwm-workspace--switch-map map))) + +(defun exwm-workspace--workspace-from-frame-or-index (frame-or-index) + "Retrieve the workspace frame from FRAME-OR-INDEX." + (cond + ((framep frame-or-index) + (unless (exwm-workspace--position frame-or-index) + (user-error "[EXWM] Frame is not a workspace %S" frame-or-index)) + frame-or-index) + ((integerp frame-or-index) + (unless (and (<= 0 frame-or-index) + (< frame-or-index (exwm-workspace--count))) + (user-error "[EXWM] Workspace index out of range: %d" frame-or-index)) + (elt exwm-workspace--list frame-or-index)) + (t (user-error "[EXWM] Invalid workspace: %s" frame-or-index)))) + +(defun exwm-workspace--prompt-for-workspace (&optional prompt) + "Prompt for a workspace, returning the workspace frame. +Show PROMPT to the user if non-nil." + (exwm-workspace--update-switch-history) + (let* ((current-idx (exwm-workspace--position exwm-workspace--current)) + (history-add-new-input nil) ;prevent modifying history + (history-idx (read-from-minibuffer + (or prompt "Workspace: ") + (elt exwm-workspace--switch-history current-idx) + exwm-workspace--switch-map nil + `(exwm-workspace--switch-history . ,(1+ current-idx)))) + (workspace-idx (cl-position history-idx exwm-workspace--switch-history + :test #'equal))) + (elt exwm-workspace--list workspace-idx))) + +(defun exwm-workspace--prompt-add () + "Add workspace from the prompt." + (interactive) + (when exwm-workspace--prompt-add-allowed + (let ((exwm-workspace--create-silently t)) + (make-frame) + (run-hooks 'exwm-workspace-list-change-hook)) + (exwm-workspace--update-switch-history) + (goto-history-element minibuffer-history-position))) + +(defun exwm-workspace--prompt-delete () + "Delete workspace from the prompt." + (interactive) + (when (and exwm-workspace--prompt-delete-allowed + (< 1 (exwm-workspace--count))) + (let ((frame (elt exwm-workspace--list (1- minibuffer-history-position)))) + (if (eq frame exwm-workspace--current) + ;; Abort the recursive minibuffer if deleting the current workspace. + (progn + (exwm--defer 0 #'delete-frame frame) + (abort-recursive-edit)) + (delete-frame frame) + (exwm-workspace--update-switch-history) + (goto-history-element (min minibuffer-history-position + (exwm-workspace--count))))))) + +(defun exwm-workspace--update-switch-history () + "Update the history for switching workspace to reflect the latest status." + (when exwm-workspace--switch-history-outdated + (setq exwm-workspace--switch-history-outdated nil) + (let* ((num (exwm-workspace--count)) + (sequence (number-sequence 0 (1- num))) + (not-empty (make-vector num nil))) + (dolist (i exwm--id-buffer-alist) + (with-current-buffer (cdr i) + (when exwm--frame + (setf (aref not-empty + (exwm-workspace--position exwm--frame)) + t)))) + (setq exwm-workspace--switch-history + (mapcar + (lambda (i) + (mapconcat + (lambda (j) + (format (if (= i j) "[%s]" " %s ") + (propertize + (apply exwm-workspace-index-map (list j)) + 'face + (cond ((frame-parameter (elt exwm-workspace--list j) + 'exwm-urgency) + '(:foreground "orange")) + ((aref not-empty j) '(:foreground "green")) + (t nil))))) + sequence "")) + sequence))))) + +;;;###autoload +(defun exwm-workspace--get-geometry (frame) + "Return the geometry of frame FRAME." + (or (frame-parameter frame 'exwm-geometry) + (make-instance 'xcb:RECTANGLE + :x 0 + :y 0 + :width (x-display-pixel-width) + :height (x-display-pixel-height)))) + +;;;###autoload +(defun exwm-workspace--current-height () + "Return the height of current workspace." + (let ((geometry (frame-parameter exwm-workspace--current 'exwm-geometry))) + (if geometry + (slot-value geometry 'height) + (x-display-pixel-height)))) + +;;;###autoload +(defun exwm-workspace--minibuffer-own-frame-p () + "Reports whether the minibuffer is displayed in its own frame." + (memq exwm-workspace-minibuffer-position '(top bottom))) + +(defun exwm-workspace--update-struts () + "Update `exwm-workspace--struts'." + (setq exwm-workspace--struts nil) + (let (struts struts*) + (dolist (pair exwm-workspace--id-struts-alist) + (setq struts (cdr pair)) + (when struts + (dotimes (i 4) + (when (/= 0 (aref struts i)) + (setq struts* + (vector (aref [left right top bottom] i) + (aref struts i) + (when (= 12 (length struts)) + (substring struts (+ 4 (* i 2)) (+ 6 (* i 2)))))) + (if (= 0 (mod i 2)) + ;; Make left/top processed first. + (push struts* exwm-workspace--struts) + (setq exwm-workspace--struts + (append exwm-workspace--struts (list struts*)))))))) + (exwm--log "%s" exwm-workspace--struts))) + +(defun exwm-workspace--update-workareas () + "Update `exwm-workspace--workareas'." + (let* ((root-width (x-display-pixel-width)) + (root-height (x-display-pixel-height)) + ;; Get workareas prior to struts. + (workareas (mapcar + (lambda (frame) + (if-let (rect (frame-parameter frame 'exwm-geometry)) + ;; Use the 'exwm-geometry' frame parameter if it + ;; exists. Make sure to clone it, will be modified + ;; below! + (clone rect) + ;; Fall back to use the screen size. + (make-instance 'xcb:RECTANGLE + :x 0 + :y 0 + :width root-width + :height root-height))) + exwm-workspace--list))) + ;; Exclude areas occupied by struts. + (dolist (struts exwm-workspace--struts) + (let* ((edge (aref struts 0)) + (size (aref struts 1)) + (position (aref struts 2)) + (beg (and position (aref position 0))) + (end (and position (aref position 1))) + delta) + (dolist (w workareas) + (with-slots (x y width height) w + (pcase edge + ;; Left and top are always processed first. + ('left + (setq delta (- size x)) + (when (and (< 0 delta) + (< delta width) + (or (not position) + (< (max beg y) + (min end (+ y height))))) + (cl-decf width delta) + (setf x size))) + ('right + (setq delta (- size (- root-width x width))) + (when (and (< 0 delta) + (< delta width) + (or (not position) + (< (max beg y) + (min end (+ y height))))) + (cl-decf width delta))) + ('top + (setq delta (- size y)) + (when (and (< 0 delta) + (< delta height) + (or (not position) + (< (max beg x) + (min end (+ x width))))) + (cl-decf height delta) + (setf y size))) + ('bottom + (setq delta (- size (- root-height y height))) + (when (and (< 0 delta) + (< delta height) + (or (not position) + (< (max beg x) + (min end (+ x width))))) + (cl-decf height delta)))))))) + ;; Save the result. + (setq exwm-workspace--workareas workareas) + (xcb:flush exwm--connection)) + (exwm--log "%s" exwm-workspace--workareas) + (run-hooks 'exwm-workspace--update-workareas-hook)) + +(defun exwm-workspace--update-offsets () + "Update `exwm-workspace--frame-y-offset'/`exwm-workspace--window-y-offset'." + (exwm--log) + (if (not (and exwm-workspace--list + (or menu-bar-mode tool-bar-mode))) + (setq exwm-workspace--frame-y-offset 0 + exwm-workspace--window-y-offset 0) + (redisplay t) + (let* ((frame (elt exwm-workspace--list 0)) + (edges (window-inside-absolute-pixel-edges (frame-first-window + frame)))) + (with-slots (y) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable (frame-parameter frame + 'exwm-container))) + (with-slots ((y* y)) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable (frame-parameter frame + 'exwm-outer-id))) + (with-slots ((y** y)) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable (frame-parameter frame 'exwm-id))) + (setq exwm-workspace--frame-y-offset (- y** y*) + exwm-workspace--window-y-offset (- (elt edges 1) y)))))))) + +(defun exwm-workspace--set-active (frame active) + "Make frame FRAME active on its monitor. +ACTIVE indicates whether to set the frame active or inactive." + (exwm--log "active=%s; frame=%s" active frame) + (set-frame-parameter frame 'exwm-active active) + (if active + (exwm-workspace--set-fullscreen frame) + (exwm--set-geometry (frame-parameter frame 'exwm-container) nil nil 1 1)) + (exwm-layout--refresh frame) + (xcb:flush exwm--connection)) + +(defun exwm-workspace--active-p (frame) + "Return non-nil if FRAME is active." + (frame-parameter frame 'exwm-active)) + +(defun exwm-workspace--set-fullscreen (frame) + "Make frame FRAME fullscreen according to `exwm-workspace--workareas'." + (exwm--log "frame=%s" frame) + (let ((id (frame-parameter frame 'exwm-outer-id)) + (container (frame-parameter frame 'exwm-container))) + (with-slots (x y width height) + (exwm-workspace--workarea frame) + (exwm--log "x=%s; y=%s; w=%s; h=%s" x y width height) + (when (and (eq frame exwm-workspace--current) + (exwm-workspace--minibuffer-own-frame-p)) + (exwm-workspace--resize-minibuffer-frame)) + (if (exwm-workspace--active-p frame) + (exwm--set-geometry container x y width height) + (exwm--set-geometry container x y 1 1)) + (exwm--set-geometry id nil nil width height) + (xcb:flush exwm--connection))) + ;; This is only used for workspace initialization. + (when exwm-workspace--fullscreen-frame-count + (cl-incf exwm-workspace--fullscreen-frame-count))) + +(defun exwm-workspace--resize-minibuffer-frame () + "Resize minibuffer (and its container) to fit the size of workspace." + (cl-assert (exwm-workspace--minibuffer-own-frame-p)) + (let ((workarea (exwm-workspace--workarea exwm-workspace-current-index)) + (container (frame-parameter exwm-workspace--minibuffer + 'exwm-container)) + y width) + (setq y (if (eq exwm-workspace-minibuffer-position 'top) + (- (slot-value workarea 'y) + exwm-workspace--attached-minibuffer-height) + ;; Reset the frame size. + (set-frame-height exwm-workspace--minibuffer 1) + (redisplay) ;FIXME. + (+ (slot-value workarea 'y) (slot-value workarea 'height) + (- (frame-pixel-height exwm-workspace--minibuffer)) + exwm-workspace--attached-minibuffer-height)) + width (slot-value workarea 'width)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window container + :value-mask (logior xcb:ConfigWindow:X + xcb:ConfigWindow:Y + xcb:ConfigWindow:Width + (if exwm-manage--desktop + xcb:ConfigWindow:Sibling + 0) + xcb:ConfigWindow:StackMode) + :x (slot-value workarea 'x) + :y y + :width width + :sibling exwm-manage--desktop + :stack-mode (if exwm-manage--desktop + xcb:StackMode:Above + xcb:StackMode:Below))) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm-workspace--minibuffer + 'exwm-outer-id) + :value-mask xcb:ConfigWindow:Width + :width width)) + (exwm--log "y: %s, width: %s" y width))) + +(defun exwm-workspace--switch-map-nth-prefix (&optional prefix-digits) + "Allow selecting a workspace by number. + +PREFIX-DIGITS is a list of the digits introduced so far." + (interactive) + (let* ((k (aref (substring (this-command-keys-vector) -1) 0)) + (d (- k ?0)) + ;; Convert prefix-digits to number. For example, '(2 1) to 120. + (o 1) + (pn (apply #'+ (mapcar (lambda (x) + (setq o (* 10 o)) + (* o x)) + prefix-digits))) + (n (+ pn d)) + prefix-length index-max index-length) + (if (or (= n 0) + (> n + (setq index-max (1- (exwm-workspace--count)))) + (>= (setq prefix-length (length prefix-digits)) + (setq index-length (floor (log index-max 10)))) + ;; Check if it's still possible to do a match. + (> (* n (expt 10 (- index-length prefix-length))) + index-max)) + (exwm-workspace--switch-map-select-nth n) + ;; Go ahead if there are enough digits to select any workspace. + (set-transient-map + (let ((map (make-sparse-keymap)) + (cmd (let ((digits (cons d prefix-digits))) + (lambda () + (interactive) + (exwm-workspace--switch-map-nth-prefix digits))))) + (dotimes (i 10) + (define-key map (int-to-string i) cmd)) + ;; Accept + (define-key map [return] + (lambda () + (interactive) + (exwm-workspace--switch-map-select-nth n))) + map))))) + +(defun exwm-workspace--switch-map-select-nth (n) + "Select Nth workspace." + (interactive) + (goto-history-element (1+ n)) + (exit-minibuffer)) + +;;;###autoload +(defun exwm-workspace-switch (frame-or-index &optional force) + "Switch to workspace FRAME-OR-INDEX (0-based). + +Query for the index if not specified when called interactively. Passing a +workspace frame as the first option or making use of the rest options are +for internal use only. + +When FORCE is true, allow switching to current workspace." + (interactive + (list + (cond + ((null current-prefix-arg) + (unless (and (derived-mode-p 'exwm-mode) + ;; The prompt is invisible in fullscreen mode. + (exwm-layout--fullscreen-p)) + (let ((exwm-workspace--prompt-add-allowed t) + (exwm-workspace--prompt-delete-allowed t)) + (exwm-workspace--prompt-for-workspace "Switch to [+/-]: ")))) + ((and (integerp current-prefix-arg) + (<= 0 current-prefix-arg (exwm-workspace--count))) + current-prefix-arg) + (t 0)))) + (exwm--log) + (let* ((frame (exwm-workspace--workspace-from-frame-or-index frame-or-index)) + (old-frame exwm-workspace--current) + (index (exwm-workspace--position frame)) + (window (frame-parameter frame 'exwm-selected-window))) + (when (or force (not (eq frame exwm-workspace--current))) + (unless (window-live-p window) + (setq window (frame-selected-window frame))) + (when (and (not (eq frame old-frame)) + (frame-live-p old-frame)) + (with-selected-frame old-frame + (funcall exwm-workspace--original-handle-focus-out + (list 'focus-out frame)))) + ;; Raise this frame. + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter frame 'exwm-container) + :value-mask (logior xcb:ConfigWindow:Sibling + xcb:ConfigWindow:StackMode) + :sibling exwm--guide-window + :stack-mode xcb:StackMode:Below)) + (setq exwm-workspace--current frame + exwm-workspace-current-index index) + (unless (exwm-workspace--workspace-p (selected-frame)) + ;; Save the floating frame window selected on the previous workspace. + (set-frame-parameter (buffer-local-value 'exwm--frame (window-buffer)) + 'exwm-selected-window (selected-window))) + ;; Show/Hide X windows. + (let ((monitor-old (frame-parameter old-frame 'exwm-randr-monitor)) + (monitor-new (frame-parameter frame 'exwm-randr-monitor)) + (active-old (exwm-workspace--active-p old-frame)) + (active-new (exwm-workspace--active-p frame)) + workspaces-to-hide) + (cond + ((not active-old) + (exwm-workspace--set-active frame t)) + ((equal monitor-old monitor-new) + (exwm-workspace--set-active frame t) + (unless (eq frame old-frame) + (exwm-workspace--set-active old-frame nil) + (setq workspaces-to-hide (list old-frame)))) + (active-new) + (t + (dolist (w exwm-workspace--list) + (when (and (exwm-workspace--active-p w) + (equal monitor-new + (frame-parameter w 'exwm-randr-monitor))) + (exwm-workspace--set-active w nil) + (setq workspaces-to-hide (append workspaces-to-hide (list w))))) + (exwm-workspace--set-active frame t))) + (dolist (i exwm--id-buffer-alist) + (with-current-buffer (cdr i) + (if (memq exwm--frame workspaces-to-hide) + (exwm-layout--hide exwm--id) + (when (eq frame exwm--frame) + (let ((window (get-buffer-window nil t))) + (when window + (exwm-layout--show exwm--id window)))))))) + (select-window window) + (x-focus-frame (window-frame window)) ;The real input focus. + (set-frame-parameter frame 'exwm-selected-window nil) + (if (exwm-workspace--minibuffer-own-frame-p) + ;; Resize the minibuffer frame. + (exwm-workspace--resize-minibuffer-frame) + ;; Set a default minibuffer frame. + (setq default-minibuffer-frame frame)) + ;; Hide windows in other workspaces by preprending a space + (unless exwm-workspace-show-all-buffers + (dolist (i exwm--id-buffer-alist) + (with-current-buffer (cdr i) + (let ((name (replace-regexp-in-string "^\\s-*" "" + (buffer-name)))) + (exwm-workspace-rename-buffer (if (eq frame exwm--frame) + name + (concat " " name))))))) + ;; Update demands attention flag + (set-frame-parameter frame 'exwm-urgency nil) + ;; Update switch workspace history + (setq exwm-workspace--switch-history-outdated t) + ;; Set _NET_CURRENT_DESKTOP + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_CURRENT_DESKTOP + :window exwm--root :data index)) + (xcb:flush exwm--connection)) + (when exwm-workspace-warp-cursor + (with-slots (win-x win-y) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:QueryPointer + :window (frame-parameter frame + 'exwm-outer-id))) + (when (or (< win-x 0) + (< win-y 0) + (> win-x (frame-pixel-width frame)) + (> win-y (frame-pixel-height frame))) + (xcb:+request exwm--connection + (make-instance 'xcb:WarpPointer + :src-window xcb:Window:None + :dst-window (frame-parameter frame + 'exwm-outer-id) + :src-x 0 + :src-y 0 + :src-width 0 + :src-height 0 + :dst-x (/ (frame-pixel-width frame) 2) + :dst-y (/ (frame-pixel-height frame) 2))) + (xcb:flush exwm--connection)))) + (funcall exwm-workspace--original-handle-focus-in (list 'focus-in frame)) + (run-hooks 'exwm-workspace-switch-hook))) + +;;;###autoload +(defun exwm-workspace-switch-create (frame-or-index) + "Switch to workspace FRAME-OR-INDEX creating it first non-existent. + +Passing a workspace frame as the first option is for internal use only." + (interactive + (list + (cond + ((integerp current-prefix-arg) + current-prefix-arg) + (t 0)))) + (unless frame-or-index + (setq frame-or-index 0)) + (exwm--log "%s" frame-or-index) + (if (or (framep frame-or-index) + (< frame-or-index (exwm-workspace--count))) + (exwm-workspace-switch frame-or-index) + (let ((exwm-workspace--create-silently t)) + (dotimes (_ (min exwm-workspace-switch-create-limit + (1+ (- frame-or-index + (exwm-workspace--count))))) + (make-frame)) + (run-hooks 'exwm-workspace-list-change-hook)) + (exwm-workspace-switch frame-or-index))) + +;;;###autoload +(defun exwm-workspace-swap (workspace1 workspace2) + "Interchange position of WORKSPACE1 with that of WORKSPACE2." + (interactive + (unless (and (derived-mode-p 'exwm-mode) + ;; The prompt is invisible in fullscreen mode. + (exwm-layout--fullscreen-p)) + (let (w1 w2) + (let ((exwm-workspace--prompt-add-allowed t) + (exwm-workspace--prompt-delete-allowed t)) + (setq w1 (exwm-workspace--prompt-for-workspace + "Pick a workspace [+/-]: "))) + (setq w2 (exwm-workspace--prompt-for-workspace + (format "Swap workspace %d with: " + (exwm-workspace--position w1)))) + (list w1 w2)))) + (exwm--log) + (let ((pos1 (exwm-workspace--position workspace1)) + (pos2 (exwm-workspace--position workspace2))) + (if (or (not pos1) (not pos2) (= pos1 pos2)) + (user-error "[EXWM] Cannot swap %s and %s" workspace1 workspace2) + (setf (elt exwm-workspace--list pos1) workspace2) + (setf (elt exwm-workspace--list pos2) workspace1) + ;; Update the _NET_WM_DESKTOP property of each X window affected. + (dolist (pair exwm--id-buffer-alist) + (when (memq (buffer-local-value 'exwm--frame (cdr pair)) + (list workspace1 workspace2)) + (exwm-workspace--set-desktop (car pair)))) + (xcb:flush exwm--connection) + (when (memq exwm-workspace--current (list workspace1 workspace2)) + ;; With the current workspace involved, lots of stuffs need refresh. + (set-frame-parameter exwm-workspace--current 'exwm-selected-window + (selected-window)) + (exwm-workspace-switch exwm-workspace--current t)) + (run-hooks 'exwm-workspace-list-change-hook)))) + +;;;###autoload +(defun exwm-workspace-move (workspace nth) + "Move WORKSPACE to the NTH position. + +When called interactively, prompt for a workspace and move current one just +before it." + (interactive + (cond + ((null current-prefix-arg) + (unless (and (derived-mode-p 'exwm-mode) + ;; The prompt is invisible in fullscreen mode. + (exwm-layout--fullscreen-p)) + (list exwm-workspace--current + (exwm-workspace--position + (exwm-workspace--prompt-for-workspace "Move workspace to: "))))) + ((and (integerp current-prefix-arg) + (<= 0 current-prefix-arg (exwm-workspace--count))) + (list exwm-workspace--current current-prefix-arg)) + (t (list exwm-workspace--current 0)))) + (exwm--log) + (let ((pos (exwm-workspace--position workspace)) + flag start end index) + (if (= nth pos) + (user-error "[EXWM] Cannot move to same position") + ;; Set if the current workspace is involved. + (setq flag (or (eq workspace exwm-workspace--current) + (eq (elt exwm-workspace--list nth) + exwm-workspace--current))) + ;; Do the move. + (with-no-warnings ;For Emacs 24. + (pop (nthcdr pos exwm-workspace--list))) + (push workspace (nthcdr nth exwm-workspace--list)) + ;; Update the _NET_WM_DESKTOP property of each X window affected. + (setq start (min pos nth) + end (max pos nth)) + (dolist (pair exwm--id-buffer-alist) + (setq index (exwm-workspace--position + (buffer-local-value 'exwm--frame (cdr pair)))) + (unless (or (< index start) (> index end)) + (exwm-workspace--set-desktop (car pair)))) + (when flag + ;; With the current workspace involved, lots of stuffs need refresh. + (set-frame-parameter exwm-workspace--current 'exwm-selected-window + (selected-window)) + (exwm-workspace-switch exwm-workspace--current t)) + (run-hooks 'exwm-workspace-list-change-hook)))) + +;;;###autoload +(defun exwm-workspace-add (&optional index) + "Add a workspace as the INDEX-th workspace, or the last one if INDEX is nil. + +INDEX must not exceed the current number of workspaces." + (interactive) + (exwm--log "%s" index) + (if (and index + ;; No need to move if it's the last one. + (< index (exwm-workspace--count))) + (exwm-workspace-move (make-frame) index) + (make-frame))) + +;;;###autoload +(defun exwm-workspace-delete (&optional frame-or-index) + "Delete the workspace FRAME-OR-INDEX." + (interactive) + (exwm--log "%s" frame-or-index) + (when (< 1 (exwm-workspace--count)) + (let ((frame (if frame-or-index + (exwm-workspace--workspace-from-frame-or-index + frame-or-index) + exwm-workspace--current))) + (delete-frame frame)))) + +(defun exwm-workspace--set-desktop (id) + "Set _NET_WM_DESKTOP for X window ID." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (let ((desktop (exwm-workspace--position exwm--frame))) + (setq exwm--desktop desktop) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_DESKTOP + :window id + :data desktop))))) + +;;;###autoload +(cl-defun exwm-workspace-move-window (frame-or-index &optional id) + "Move window ID to workspace FRAME-OR-INDEX." + (interactive (list + (cond + ((null current-prefix-arg) + (let ((exwm-workspace--prompt-add-allowed t) + (exwm-workspace--prompt-delete-allowed t)) + (exwm-workspace--prompt-for-workspace "Move to [+/-]: "))) + ((and (integerp current-prefix-arg) + (<= 0 current-prefix-arg (exwm-workspace--count))) + current-prefix-arg) + (t 0)))) + (let ((frame (exwm-workspace--workspace-from-frame-or-index frame-or-index)) + old-frame container) + (unless id (setq id (exwm--buffer->id (window-buffer)))) + (unless id + (cl-return-from exwm-workspace-move-window)) + (exwm--log "Moving #x%x to %s" id frame-or-index) + (with-current-buffer (exwm--id->buffer id) + (unless (eq exwm--frame frame) + (unless exwm-workspace-show-all-buffers + (let ((name (replace-regexp-in-string "^\\s-*" "" (buffer-name)))) + (exwm-workspace-rename-buffer + (if (eq frame exwm-workspace--current) + name + (concat " " name))))) + (setq old-frame exwm--frame + exwm--frame frame) + (if (not exwm--floating-frame) + ;; Tiling. + (if (get-buffer-window nil frame) + (when (eq frame exwm-workspace--current) + (exwm-layout--refresh frame)) + (set-window-buffer (get-buffer-window nil t) + (other-buffer nil t)) + (unless (eq frame exwm-workspace--current) + ;; Clear the 'exwm-selected-window' frame parameter. + (set-frame-parameter frame 'exwm-selected-window nil)) + (set-window-buffer (frame-selected-window frame) + (exwm--id->buffer id)) + (if (eq frame exwm-workspace--current) + (select-window (frame-selected-window frame)) + (unless (exwm-workspace--active-p frame) + (exwm-layout--hide id)))) + ;; Floating. + (setq container (frame-parameter exwm--floating-frame + 'exwm-container)) + (unless (equal (frame-parameter old-frame 'exwm-randr-monitor) + (frame-parameter frame 'exwm-randr-monitor)) + (with-slots (x y) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry + :drawable container)) + (with-slots ((x1 x) + (y1 y)) + (exwm-workspace--get-geometry old-frame) + (with-slots ((x2 x) + (y2 y)) + (exwm-workspace--get-geometry frame) + (setq x (+ x (- x2 x1)) + y (+ y (- y2 y1))))) + (exwm--set-geometry id x y nil nil) + (exwm--set-geometry container x y nil nil))) + (if (exwm-workspace--minibuffer-own-frame-p) + (if (eq frame exwm-workspace--current) + (select-window (frame-root-window exwm--floating-frame)) + (select-window (frame-selected-window exwm-workspace--current)) + (unless (exwm-workspace--active-p frame) + (exwm-layout--hide id))) + ;; The frame needs to be recreated since it won't use the + ;; minibuffer on the new workspace. + ;; The code is mostly copied from `exwm-floating--set-floating'. + (let* ((old-frame exwm--floating-frame) + (new-frame + (with-current-buffer + (or (get-buffer "*scratch*") + (progn + (set-buffer-major-mode + (get-buffer-create "*scratch*")) + (get-buffer "*scratch*"))) + (make-frame + `((minibuffer . ,(minibuffer-window frame)) + (left . ,(* window-min-width -100)) + (top . ,(* window-min-height -100)) + (width . ,window-min-width) + (height . ,window-min-height) + (unsplittable . t))))) + (outer-id (string-to-number + (frame-parameter new-frame + 'outer-window-id))) + (window-id (string-to-number + (frame-parameter new-frame 'window-id))) + (window (frame-root-window new-frame))) + (set-frame-parameter new-frame 'exwm-outer-id outer-id) + (set-frame-parameter new-frame 'exwm-id window-id) + (set-frame-parameter new-frame 'exwm-container container) + (make-frame-invisible new-frame) + (set-frame-size new-frame + (frame-pixel-width old-frame) + (frame-pixel-height old-frame) + t) + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window outer-id + :parent container + :x 0 :y 0)) + (xcb:flush exwm--connection) + (with-current-buffer (exwm--id->buffer id) + (setq window-size-fixed nil + exwm--floating-frame new-frame) + (set-window-dedicated-p (frame-root-window old-frame) nil) + (remove-hook 'window-configuration-change-hook + #'exwm-layout--refresh) + (set-window-buffer window (current-buffer)) + (add-hook 'window-configuration-change-hook + #'exwm-layout--refresh) + (set-window-dedicated-p window t)) + ;; Select a tiling window and delete the old frame. + (select-window (frame-selected-window exwm-workspace--current)) + (delete-frame old-frame) + ;; The rest is the same. + (make-frame-visible new-frame) + (exwm--set-geometry outer-id 0 0 nil nil) + (xcb:flush exwm--connection) + (redisplay) + (if (eq frame exwm-workspace--current) + (with-current-buffer (exwm--id->buffer id) + (select-window (frame-root-window exwm--floating-frame))) + (unless (exwm-workspace--active-p frame) + (exwm-layout--hide id))))) + ;; Update the 'exwm-selected-window' frame parameter. + (when (not (eq frame exwm-workspace--current)) + (with-current-buffer (exwm--id->buffer id) + (set-frame-parameter frame 'exwm-selected-window + (frame-root-window + exwm--floating-frame))))) + ;; Set _NET_WM_DESKTOP. + (exwm-workspace--set-desktop id) + (xcb:flush exwm--connection))) + (setq exwm-workspace--switch-history-outdated t))) + +;;;###autoload +(defun exwm-workspace-switch-to-buffer (buffer-or-name) + "Make selected window display BUFFER-OR-NAME." + (interactive + (let ((inhibit-quit t)) + ;; Show all buffers + (unless exwm-workspace-show-all-buffers + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (when (= ?\s (aref (buffer-name) 0)) + (let ((buffer-list-update-hook + (remq #'exwm-input--on-buffer-list-update + buffer-list-update-hook))) + (rename-buffer (substring (buffer-name) 1))))))) + (prog1 + (with-local-quit + (list (get-buffer (read-buffer-to-switch "Switch to buffer: ")))) + ;; Hide buffers on other workspaces + (unless exwm-workspace-show-all-buffers + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (unless (or (eq exwm--frame exwm-workspace--current) + (= ?\s (aref (buffer-name) 0))) + (let ((buffer-list-update-hook + (remq #'exwm-input--on-buffer-list-update + buffer-list-update-hook))) + (rename-buffer (concat " " (buffer-name))))))))))) + (exwm--log) + (when buffer-or-name + (with-current-buffer buffer-or-name + (if (derived-mode-p 'exwm-mode) + ;; EXWM buffer. + (if (eq exwm--frame exwm-workspace--current) + ;; On the current workspace. + (if (not exwm--floating-frame) + (switch-to-buffer buffer-or-name) + ;; Select the floating frame. + (select-frame-set-input-focus exwm--floating-frame) + (select-window (frame-root-window exwm--floating-frame))) + ;; On another workspace. + (if exwm-layout-show-all-buffers + (exwm-workspace-move-window exwm-workspace--current + exwm--id) + (let ((window (get-buffer-window buffer-or-name exwm--frame))) + (if window + (set-frame-parameter exwm--frame + 'exwm-selected-window window) + (set-window-buffer (frame-selected-window exwm--frame) + buffer-or-name))) + (exwm-workspace-switch exwm--frame))) + ;; Ordinary buffer. + (switch-to-buffer buffer-or-name))))) + +(defun exwm-workspace-rename-buffer (newname) + "Rename current buffer to NEWNAME." + (let ((hidden (= ?\s (aref newname 0))) + (basename (replace-regexp-in-string "<[0-9]+>$" "" newname)) + (counter 1) + tmp) + (when hidden (setq basename (substring basename 1))) + (setq newname basename) + (while (and (setq tmp (or (get-buffer newname) + (get-buffer (concat " " newname)))) + (not (eq tmp (current-buffer)))) + (setq newname (format "%s<%d>" basename (cl-incf counter)))) + (let ((buffer-list-update-hook + (remq #'exwm-input--on-buffer-list-update + buffer-list-update-hook))) + (rename-buffer (concat (and hidden " ") newname))))) + +(defun exwm-workspace--x-create-frame (orig-x-create-frame params) + "Set override-redirect on the frame created by `x-create-frame'. +ORIG-X-CREATE-FRAME is the advised function `x-create-frame'. +PARAMS are the original arguments." + (exwm--log) + (let ((frame (funcall orig-x-create-frame params))) + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window (string-to-number + (frame-parameter frame 'outer-window-id)) + :value-mask xcb:CW:OverrideRedirect + :override-redirect 1)) + (xcb:flush exwm--connection) + frame)) + +(defsubst exwm-workspace--minibuffer-attached-p () + "Return non-nil if the minibuffer is attached. + +Please check `exwm-workspace--minibuffer-own-frame-p' first." + (assq (frame-parameter exwm-workspace--minibuffer 'exwm-container) + exwm-workspace--id-struts-alist)) + +;;;###autoload +(defun exwm-workspace-attach-minibuffer () + "Attach the minibuffer making it always visible." + (interactive) + (exwm--log) + (when (and (exwm-workspace--minibuffer-own-frame-p) + (not (exwm-workspace--minibuffer-attached-p))) + ;; Reset the frame size. + (set-frame-height exwm-workspace--minibuffer 1) + (redisplay) ;FIXME. + (setq exwm-workspace--attached-minibuffer-height + (frame-pixel-height exwm-workspace--minibuffer)) + (exwm-workspace--show-minibuffer) + (let ((container (frame-parameter exwm-workspace--minibuffer + 'exwm-container))) + (push (cons container + (if (eq exwm-workspace-minibuffer-position 'top) + (vector 0 0 exwm-workspace--attached-minibuffer-height 0) + (vector 0 0 0 exwm-workspace--attached-minibuffer-height))) + exwm-workspace--id-struts-alist) + (exwm-workspace--update-struts) + (exwm-workspace--update-workareas) + (dolist (f exwm-workspace--list) + (exwm-workspace--set-fullscreen f))))) + +;;;###autoload +(defun exwm-workspace-detach-minibuffer () + "Detach the minibuffer so that it automatically hides." + (interactive) + (exwm--log) + (when (and (exwm-workspace--minibuffer-own-frame-p) + (exwm-workspace--minibuffer-attached-p)) + (setq exwm-workspace--attached-minibuffer-height 0) + (let ((container (frame-parameter exwm-workspace--minibuffer + 'exwm-container))) + (setq exwm-workspace--id-struts-alist + (assq-delete-all container exwm-workspace--id-struts-alist)) + (exwm-workspace--update-struts) + (exwm-workspace--update-workareas) + (dolist (f exwm-workspace--list) + (exwm-workspace--set-fullscreen f)) + (exwm-workspace--hide-minibuffer)))) + +;;;###autoload +(defun exwm-workspace-toggle-minibuffer () + "Attach the minibuffer if it's detached, or detach it if it's attached." + (interactive) + (exwm--log) + (when (exwm-workspace--minibuffer-own-frame-p) + (if (exwm-workspace--minibuffer-attached-p) + (exwm-workspace-detach-minibuffer) + (exwm-workspace-attach-minibuffer)))) + +(defun exwm-workspace--update-minibuffer-height (&optional echo-area) + "Update the minibuffer frame height. +When ECHO-AREA is non-nil, take the size of the echo area into +account when calculating the height." + (when (exwm--terminal-p) + (let ((height + (with-current-buffer + (window-buffer (minibuffer-window exwm-workspace--minibuffer)) + (max 1 + (if echo-area + (let ((width (frame-width exwm-workspace--minibuffer)) + (result 0)) + (mapc (lambda (i) + (setq result + (+ result + (ceiling (1+ (length i)) width)))) + (split-string (or (current-message) "") "\n")) + result) + (count-screen-lines)))))) + (when (and (integerp max-mini-window-height) + (> height max-mini-window-height)) + (setq height max-mini-window-height)) + (exwm--log "%s" height) + (set-frame-height exwm-workspace--minibuffer height)))) + +(defun exwm-workspace--on-ConfigureNotify (data _synthetic) + "Adjust the container to fit the minibuffer frame. +DATA contains unmarshalled ConfigureNotify event data." + (let ((obj (make-instance 'xcb:ConfigureNotify)) y) + (xcb:unmarshal obj data) + (with-slots (window height) obj + (when (eq (frame-parameter exwm-workspace--minibuffer 'exwm-outer-id) + window) + (exwm--log) + (when (and (floatp max-mini-window-height) + (> height (* max-mini-window-height + (exwm-workspace--current-height)))) + (setq height (floor + (* max-mini-window-height + (exwm-workspace--current-height)))) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window window + :value-mask xcb:ConfigWindow:Height + :height height))) + (when (/= (exwm-workspace--count) (length exwm-workspace--workareas)) + ;; There is a chance the workareas are not updated timely. + (exwm-workspace--update-workareas)) + (with-slots ((y* y) (height* height)) + (exwm-workspace--workarea exwm-workspace-current-index) + (setq y (if (eq exwm-workspace-minibuffer-position 'top) + (- y* + exwm-workspace--attached-minibuffer-height) + (+ y* height* (- height) + exwm-workspace--attached-minibuffer-height)))) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm-workspace--minibuffer + 'exwm-container) + :value-mask (logior xcb:ConfigWindow:Y + xcb:ConfigWindow:Height) + :y y + :height height)) + (xcb:flush exwm--connection))))) + +(defun exwm-workspace--display-buffer (buffer alist) + "Display BUFFER as if the current workspace were selected. +ALIST is an action alist, as accepted by function `display-buffer'." + ;; Only when the floating minibuffer frame is selected. + ;; This also protect this functions from being recursively called. + (when (eq (selected-frame) exwm-workspace--minibuffer) + (with-selected-frame exwm-workspace--current + (display-buffer buffer alist)))) + +(defun exwm-workspace--show-minibuffer () + "Show the minibuffer frame." + (exwm--log) + ;; Cancel pending timer. + (when exwm-workspace--display-echo-area-timer + (cancel-timer exwm-workspace--display-echo-area-timer) + (setq exwm-workspace--display-echo-area-timer nil)) + ;; Show the minibuffer frame. + (unless (exwm-workspace--minibuffer-attached-p) + (exwm--set-geometry (frame-parameter exwm-workspace--minibuffer + 'exwm-container) + nil nil + (frame-pixel-width exwm-workspace--minibuffer) + (frame-pixel-height exwm-workspace--minibuffer))) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm-workspace--minibuffer + 'exwm-container) + :value-mask xcb:ConfigWindow:StackMode + :stack-mode xcb:StackMode:Above)) + (xcb:flush exwm--connection)) + +(defun exwm-workspace--hide-minibuffer () + "Hide the minibuffer frame." + (exwm--log) + ;; Hide the minibuffer frame. + (if (exwm-workspace--minibuffer-attached-p) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window (frame-parameter exwm-workspace--minibuffer + 'exwm-container) + :value-mask (logior (if exwm-manage--desktop + xcb:ConfigWindow:Sibling + 0) + xcb:ConfigWindow:StackMode) + :sibling exwm-manage--desktop + :stack-mode (if exwm-manage--desktop + xcb:StackMode:Above + xcb:StackMode:Below))) + (exwm--set-geometry (frame-parameter exwm-workspace--minibuffer + 'exwm-container) + nil nil 1 1)) + (xcb:flush exwm--connection)) + +(defun exwm-workspace--on-minibuffer-setup () + "Run in `minibuffer-setup-hook' to show the minibuffer and its container." + (exwm--log) + (when (and (= 1 (minibuffer-depth)) + (exwm--terminal-p)) + (add-hook 'post-command-hook #'exwm-workspace--update-minibuffer-height) + (exwm-workspace--show-minibuffer)) + ;; FIXME: This is a temporary fix for the *Completions* buffer not + ;; being correctly fitted by its displaying window. As with + ;; `exwm-workspace--display-buffer', the problem is caused by + ;; the fact that the minibuffer (rather than the workspace) + ;; frame is the 'selected frame'. `get-buffer-window' will + ;; fail to retrieve the correct window. It's likely there are + ;; other related issues. + ;; This is not required by Emacs 24. + (when (fboundp 'window-preserve-size) + (let ((window (get-buffer-window "*Completions*" + exwm-workspace--current))) + (when window + (fit-window-to-buffer window) + (window-preserve-size window))))) + +(defun exwm-workspace--on-minibuffer-exit () + "Run in `minibuffer-exit-hook' to hide the minibuffer container." + (exwm--log) + (when (and (= 1 (minibuffer-depth)) + (exwm--terminal-p)) + (remove-hook 'post-command-hook #'exwm-workspace--update-minibuffer-height) + (exwm-workspace--hide-minibuffer))) + +(defun exwm-workspace--on-echo-area-dirty () + "Run when new message arrives to show the echo area and its container." + (when (and (not (active-minibuffer-window)) + (or (current-message) + cursor-in-echo-area) + (exwm--terminal-p)) + (exwm-workspace--update-minibuffer-height t) + (exwm-workspace--show-minibuffer) + (unless (or (not exwm-workspace-display-echo-area-timeout) + exwm-input--during-command ;e.g. read-event + input-method-use-echo-area) + (setq exwm-workspace--display-echo-area-timer + (run-with-timer exwm-workspace-display-echo-area-timeout nil + #'exwm-workspace--echo-area-maybe-clear))))) + +(defun exwm-workspace--echo-area-maybe-clear () + "Eventually clear the echo area container." + (exwm--log) + (if (not (current-message)) + (exwm-workspace--on-echo-area-clear) + ;; Reschedule. + (cancel-timer exwm-workspace--display-echo-area-timer) + (setq exwm-workspace--display-echo-area-timer + (run-with-timer exwm-workspace-display-echo-area-timeout nil + #'exwm-workspace--echo-area-maybe-clear)))) + +(defun exwm-workspace--on-echo-area-clear () + "Run in `echo-area-clear-hook' to hide echo area container." + (when (exwm--terminal-p) + (unless (active-minibuffer-window) + (exwm-workspace--hide-minibuffer)) + (when exwm-workspace--display-echo-area-timer + (cancel-timer exwm-workspace--display-echo-area-timer) + (setq exwm-workspace--display-echo-area-timer nil)))) + +(defun exwm-workspace--set-desktop-geometry () + "Set _NET_DESKTOP_GEOMETRY." + (exwm--log) + ;; We don't support large desktop so it's the same with screen size. + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_DESKTOP_GEOMETRY + :window exwm--root + :width (x-display-pixel-width) + :height (x-display-pixel-height)))) + +(defun exwm-workspace--add-frame-as-workspace (frame) + "Configure frame FRAME to be treated as a workspace." + (exwm--log "%s" frame) + (setq exwm-workspace--list (nconc exwm-workspace--list (list frame))) + (let ((outer-id (string-to-number (frame-parameter frame + 'outer-window-id))) + (window-id (string-to-number (frame-parameter frame 'window-id))) + (container (xcb:generate-id exwm--connection)) + frame-colormap frame-visual frame-depth) + ;; Save window IDs + (set-frame-parameter frame 'exwm-outer-id outer-id) + (set-frame-parameter frame 'exwm-id window-id) + (set-frame-parameter frame 'exwm-container container) + ;; Copy RandR frame parameters from the first workspace to + ;; prevent potential problems. The values do not matter here as + ;; they'll be updated by the RandR module later. + (let ((w (car exwm-workspace--list))) + (dolist (param '(exwm-randr-monitor + exwm-geometry)) + (set-frame-parameter frame param (frame-parameter w param)))) + ;; Support transparency on the container X window when the Emacs frame + ;; does. Note that in addition to setting the visual, colormap and depth + ;; we must also reset the `:border-pixmap', as its default value is + ;; relative to the parent window, which might have a different depth. + (let* ((vdc (exwm--get-visual-depth-colormap exwm--connection outer-id))) + (setq frame-visual (car vdc)) + (setq frame-depth (cadr vdc)) + (setq frame-colormap (caddr vdc))) + (xcb:+request exwm--connection + (make-instance 'xcb:CreateWindow + :depth frame-depth + :wid container + :parent exwm--root + :x -1 + :y -1 + :width 1 + :height 1 + :border-width 0 + :class xcb:WindowClass:InputOutput + :visual frame-visual + :value-mask (logior xcb:CW:BackPixmap + xcb:CW:BorderPixel + xcb:CW:Colormap + xcb:CW:OverrideRedirect) + :background-pixmap xcb:BackPixmap:None + :border-pixel 0 + :colormap frame-colormap + :override-redirect 1)) + (xcb:+request exwm--connection + (make-instance 'xcb:ConfigureWindow + :window container + :value-mask xcb:ConfigWindow:StackMode + :stack-mode xcb:StackMode:Below)) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window container + :data + (format "EXWM workspace %d frame container" + (exwm-workspace--position frame)))) + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window outer-id :parent container :x 0 :y 0)) + (xcb:+request exwm--connection + (make-instance 'xcb:icccm:set-WM_STATE + :window outer-id + :state xcb:icccm:WM_STATE:NormalState + :icon xcb:Window:None)) + (xcb:+request exwm--connection + (make-instance 'xcb:MapWindow :window container))) + (xcb:flush exwm--connection) + ;; Delay making the workspace fullscreen until Emacs becomes idle + (exwm--defer 0 #'exwm-workspace--fullscreen-workspace frame) + ;; Update EWMH properties. + (exwm-workspace--update-ewmh-props) + (if exwm-workspace--create-silently + (setq exwm-workspace--switch-history-outdated t) + (let ((original-index exwm-workspace-current-index)) + (exwm-workspace-switch frame t) + (message "Created %s as workspace %d; switched from %d" + frame exwm-workspace-current-index original-index)) + (run-hooks 'exwm-workspace-list-change-hook))) + +(defun exwm-workspace--get-next-workspace (frame) + "Return the next workspace if workspace FRAME were removed. +Return nil if FRAME is the only workspace." + (let* ((index (exwm-workspace--position frame)) + (lastp (= index (1- (exwm-workspace--count)))) + (nextw (elt exwm-workspace--list (+ index (if lastp -1 +1))))) + (unless (eq frame nextw) + nextw))) + +(defun exwm-workspace--remove-frame-as-workspace (frame &optional quit) + "Stop treating FRAME as a workspace. +When QUIT is non-nil cleanup avoid communicating with the X server." + ;; TODO: restore all frame parameters (e.g. exwm-workspace, buffer-predicate, + ;; etc) + (exwm--log "Removing frame `%s' as workspace" frame) + (unless quit + (let* ((next-frame (exwm-workspace--get-next-workspace frame)) + (following-frames (cdr (memq frame exwm-workspace--list)))) + ;; Need to remove the workspace from the list for the correct calculation of + ;; indexes below. + (setq exwm-workspace--list (delete frame exwm-workspace--list)) + ;; Move the windows to the next workspace and switch to it. + (unless next-frame + ;; The user managed to delete the last workspace, so create a new one. + (exwm--log "Last workspace deleted; create a new one") + (let ((exwm-workspace--create-silently t)) + (setq next-frame (make-frame)))) + (dolist (pair exwm--id-buffer-alist) + (let ((other-frame (buffer-local-value 'exwm--frame (cdr pair)))) + ;; Move X windows to next-frame. + (when (eq other-frame frame) + (exwm-workspace-move-window next-frame (car pair))) + ;; Update the _NET_WM_DESKTOP property of each following X window. + (when (memq other-frame following-frames) + (exwm-workspace--set-desktop (car pair))))) + ;; If the current workspace is deleted, switch to next one. + (when (eq frame exwm-workspace--current) + (exwm-workspace-switch next-frame)))) + ;; Reparent out the frame. + (let ((outer-id (frame-parameter frame 'exwm-outer-id))) + (xcb:+request exwm--connection + (make-instance 'xcb:UnmapWindow + :window outer-id)) + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window outer-id + :parent exwm--root + :x 0 + :y 0)) + ;; Reset the override-redirect. + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window outer-id + :value-mask xcb:CW:OverrideRedirect + :override-redirect 0)) + ;; Remove fullscreen state. + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_STATE + :window outer-id + :data nil)) + (xcb:+request exwm--connection + (make-instance 'xcb:MapWindow + :window outer-id))) + ;; Destroy the container. + (xcb:+request exwm--connection + (make-instance 'xcb:DestroyWindow + :window (frame-parameter frame 'exwm-container))) + (xcb:flush exwm--connection) + ;; Update EWMH properties. + (exwm-workspace--update-ewmh-props) + ;; Update switch history. + (unless quit + (setq exwm-workspace--switch-history-outdated t) + (run-hooks 'exwm-workspace-list-change-hook))) + +(defun exwm-workspace--on-delete-frame (frame) + "Hook run upon `delete-frame' removing FRAME as a workspace." + (cond + ((not (exwm-workspace--workspace-p frame)) + (exwm--log "Frame `%s' is not a workspace" frame)) + (t + (exwm-workspace--remove-frame-as-workspace frame)))) + +(defun exwm-workspace--fullscreen-workspace (frame) + "Make workspace FRAME fullscreen. +Called from a timer." + (when (frame-live-p frame) + (set-frame-parameter frame 'fullscreen 'fullboth))) + +(defun exwm-workspace--on-after-make-frame (frame) + "Hook run upon `make-frame' that configures FRAME as a workspace." + (cond + ((exwm-workspace--workspace-p frame) + (exwm--log "Frame `%s' is already a workspace" frame)) + ((not (display-graphic-p frame)) + (exwm--log "Frame `%s' is not graphical" frame)) + ((not (eq (frame-terminal) exwm--terminal)) + (exwm--log "Frame `%s' is on a different terminal (%S instead of %S)" + frame + (frame-terminal frame) + exwm--terminal)) + ((not (string-equal + (replace-regexp-in-string "\\.0$" "" + (slot-value exwm--connection 'display)) + (replace-regexp-in-string "\\.0$" "" + (frame-parameter frame 'display)))) + (exwm--log "Frame `%s' is on a different DISPLAY (%S instead of %S)" + frame + (frame-parameter frame 'display) + (slot-value exwm--connection 'display))) + ((frame-parameter frame 'unsplittable) + ;; We create floating frames with the "unsplittable" parameter set. + ;; Though it may not be a floating frame, we won't treat an + ;; unsplittable frame as a workspace anyway. + (exwm--log "Frame `%s' is floating" frame)) + (t + (exwm--log "Adding frame `%s' as workspace" frame) + (exwm-workspace--add-frame-as-workspace frame)))) + +(defun exwm-workspace--update-ewmh-props () + "Update EWMH properties to match the workspace list." + (exwm--log) + (let ((num-workspaces (exwm-workspace--count))) + ;; Avoid setting 0 desktops. + (when (= 0 num-workspaces) + (setq num-workspaces 1)) + ;; Set _NET_NUMBER_OF_DESKTOPS. + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_NUMBER_OF_DESKTOPS + :window exwm--root :data num-workspaces)) + ;; Set _NET_DESKTOP_GEOMETRY. + (exwm-workspace--set-desktop-geometry) + ;; Update workareas. + (exwm-workspace--update-workareas)) + (xcb:flush exwm--connection)) + +(defun exwm-workspace--modify-all-x-frames-parameters (new-x-parameters) + "Modifies `window-system-default-frame-alist' for the X Window System. +NEW-X-PARAMETERS is an alist of frame parameters, merged into current +`window-system-default-frame-alist' for the X Window System. The parameters are +applied to all subsequently created X frames." + (exwm--log) + ;; The parameters are modified in place; take current + ;; ones or insert a new X-specific list. + (let ((x-parameters (or (assq 'x window-system-default-frame-alist) + (let ((new-x-parameters '(x))) + (push new-x-parameters + window-system-default-frame-alist) + new-x-parameters)))) + (setf (cdr x-parameters) + (append new-x-parameters (cdr x-parameters))))) + +(defun exwm-workspace--handle-focus-in (_orig-func _event) + "Replacement for `handle-focus-in'." + (interactive "e")) + +(defun exwm-workspace--handle-focus-out (_orig-func _event) + "Replacement for `handle-focus-out'." + (interactive "e")) + +(defun exwm-workspace--init-minibuffer-frame () + "Initialize minibuffer-only frame." + (exwm--log) + ;; Initialize workspaces without minibuffers. + (setq exwm-workspace--minibuffer + (make-frame '((window-system . x) (minibuffer . only) + (left . 10000) (right . 10000) + (width . 1) (height . 1)))) + ;; This is the only usable minibuffer frame. + (setq default-minibuffer-frame exwm-workspace--minibuffer) + (exwm-workspace--modify-all-x-frames-parameters + '((minibuffer . nil))) + (let ((outer-id (string-to-number + (frame-parameter exwm-workspace--minibuffer + 'outer-window-id))) + (window-id (string-to-number + (frame-parameter exwm-workspace--minibuffer + 'window-id))) + (container (xcb:generate-id exwm--connection))) + (set-frame-parameter exwm-workspace--minibuffer + 'exwm-outer-id outer-id) + (set-frame-parameter exwm-workspace--minibuffer 'exwm-id window-id) + (set-frame-parameter exwm-workspace--minibuffer 'exwm-container + container) + (xcb:+request exwm--connection + (make-instance 'xcb:CreateWindow + :depth 0 + :wid container + :parent exwm--root + :x 0 + :y 0 + :width 1 + :height 1 + :border-width 0 + :class xcb:WindowClass:InputOutput + :visual 0 + :value-mask (logior xcb:CW:BackPixmap + xcb:CW:OverrideRedirect) + :background-pixmap xcb:BackPixmap:ParentRelative + :override-redirect 1)) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window container + :data "EXWM minibuffer container")) + ;; Reparent the minibuffer frame to the container. + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window outer-id :parent container :x 0 :y 0)) + ;; Map the container. + (xcb:+request exwm--connection + (make-instance 'xcb:MapWindow + :window container)) + ;; Attach event listener for monitoring the frame + (xcb:+request exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window outer-id + :value-mask xcb:CW:EventMask + :event-mask xcb:EventMask:StructureNotify)) + (xcb:+event exwm--connection 'xcb:ConfigureNotify + #'exwm-workspace--on-ConfigureNotify)) + ;; Show/hide minibuffer / echo area when they're active/inactive. + (add-hook 'minibuffer-setup-hook #'exwm-workspace--on-minibuffer-setup) + (add-hook 'minibuffer-exit-hook #'exwm-workspace--on-minibuffer-exit) + (setq exwm-workspace--timer + (run-with-idle-timer 0 t #'exwm-workspace--on-echo-area-dirty)) + (add-hook 'echo-area-clear-hook #'exwm-workspace--on-echo-area-clear) + ;; The default behavior of `display-buffer' (indirectly called by + ;; `minibuffer-completion-help') is not correct here. + (cl-pushnew '(exwm-workspace--display-buffer) display-buffer-alist + :test #'equal)) + +(defun exwm-workspace--exit-minibuffer-frame () + "Cleanup minibuffer-only frame." + (exwm--log) + ;; Only on minibuffer-frame. + (remove-hook 'minibuffer-setup-hook #'exwm-workspace--on-minibuffer-setup) + (remove-hook 'minibuffer-exit-hook #'exwm-workspace--on-minibuffer-exit) + (remove-hook 'echo-area-clear-hook #'exwm-workspace--on-echo-area-clear) + (when exwm-workspace--display-echo-area-timer + (cancel-timer exwm-workspace--display-echo-area-timer)) + (when exwm-workspace--timer + (cancel-timer exwm-workspace--timer) + (setq exwm-workspace--timer nil)) + (setq display-buffer-alist + (cl-delete '(exwm-workspace--display-buffer) display-buffer-alist + :test #'equal)) + (setq default-minibuffer-frame nil) + (when (frame-live-p exwm-workspace--minibuffer) ; might be already dead + (let ((id (frame-parameter exwm-workspace--minibuffer 'exwm-outer-id))) + (when (and exwm-workspace--minibuffer id + ;; Invoked from `exwm-manage--exit' upon disconnection. + (slot-value exwm--connection 'connected)) + (xcb:+request exwm--connection + (make-instance 'xcb:ReparentWindow + :window id + :parent exwm--root + :x 0 + :y 0))) + (setq exwm-workspace--minibuffer nil)))) + +(defun exwm-workspace--init () + "Initialize workspace module." + (exwm--log) + (exwm-workspace--init-switch-map) + ;; Prevent unexpected exit + (setq exwm-workspace--fullscreen-frame-count 0) + (exwm-workspace--modify-all-x-frames-parameters + '((internal-border-width . 0))) + (let ((initial-workspaces (frame-list))) + (if (not (exwm-workspace--minibuffer-own-frame-p)) + ;; Initialize workspaces with minibuffers. + (when (< 1 (length initial-workspaces)) + ;; Exclude the initial frame. + (dolist (i initial-workspaces) + (unless (frame-parameter i 'window-id) + (setq initial-workspaces (delq i initial-workspaces)))) + (let ((f (car initial-workspaces))) + ;; Remove the possible internal border. + (set-frame-parameter f 'internal-border-width 0))) + (exwm-workspace--init-minibuffer-frame) + ;; Remove/hide existing frames. + (dolist (f initial-workspaces) + (when (eq 'x (framep f)) ;do not delete the initial frame. + (delete-frame f))) + ;; Recreate one frame with the external minibuffer set. + (setq initial-workspaces (list (make-frame '((window-system . x)))))) + ;; Prevent `other-buffer' from selecting already displayed EXWM buffers. + (modify-all-frames-parameters + '((buffer-predicate . exwm-layout--other-buffer-predicate))) + ;; Create remaining workspaces. + (dotimes (_ (- exwm-workspace-number (length initial-workspaces))) + (nconc initial-workspaces (list (make-frame '((window-system . x)))))) + ;; Configure workspaces + (let ((exwm-workspace--create-silently t)) + (dolist (i initial-workspaces) + (exwm-workspace--add-frame-as-workspace i)))) + (xcb:flush exwm--connection) + ;; We have to advice `x-create-frame' or every call to it would hang EXWM + (advice-add 'x-create-frame :around #'exwm-workspace--x-create-frame) + ;; We have to manually handle focus-in and focus-out events for Emacs + ;; frames. + (advice-add 'handle-focus-in :around #'exwm-workspace--handle-focus-in) + (advice-add 'handle-focus-out :around #'exwm-workspace--handle-focus-out) + ;; Make new frames create new workspaces. + (add-hook 'after-make-frame-functions + #'exwm-workspace--on-after-make-frame) + (add-hook 'delete-frame-functions #'exwm-workspace--on-delete-frame) + (when (exwm-workspace--minibuffer-own-frame-p) + (add-hook 'exwm-input--event-hook + #'exwm-workspace--on-echo-area-clear)) + ;; Switch to the first workspace + (exwm-workspace-switch 0 t) + ;; Prevent frame parameters introduced by this module from being + ;; saved/restored. + (dolist (i '(exwm-active exwm-outer-id exwm-id exwm-container exwm-geometry + exwm-selected-window exwm-urgency fullscreen)) + (unless (assq i frameset-filter-alist) + (push (cons i :never) frameset-filter-alist)))) + +(defun exwm-workspace--exit () + "Exit the workspace module." + (exwm--log) + (when (exwm-workspace--minibuffer-own-frame-p) + (exwm-workspace--exit-minibuffer-frame)) + (advice-remove 'x-create-frame #'exwm-workspace--x-create-frame) + (advice-remove 'handle-focus-in #'exwm-workspace--handle-focus-in) + (advice-remove 'handle-focus-out #'exwm-workspace--handle-focus-out) + (remove-hook 'after-make-frame-functions + #'exwm-workspace--on-after-make-frame) + (remove-hook 'delete-frame-functions + #'exwm-workspace--on-delete-frame) + (when (exwm-workspace--minibuffer-own-frame-p) + (remove-hook 'exwm-input--event-hook + #'exwm-workspace--on-echo-area-clear)) + ;; Hide & reparent out all frames (save-set can't be used here since + ;; X windows will be re-mapped). + (when (slot-value exwm--connection 'connected) + (dolist (i exwm-workspace--list) + (when (frame-live-p i) ; might be already dead + (exwm-workspace--remove-frame-as-workspace i 'quit) + (modify-frame-parameters i '((exwm-selected-window . nil) + (exwm-urgency . nil) + (exwm-outer-id . nil) + (exwm-id . nil) + (exwm-container . nil) + ;; (internal-border-width . nil) ; integerp + (fullscreen . nil) + (buffer-predicate . nil)))))) + ;; Don't let dead frames linger. + (setq exwm-workspace--current nil) + (setq exwm-workspace-current-index 0) + (setq exwm-workspace--list nil)) + +(defun exwm-workspace--post-init () + "The second stage in the initialization of the workspace module." + (exwm--log) + ;; Wait until all workspace frames are resized. + (with-timeout (1) + (while (< exwm-workspace--fullscreen-frame-count (exwm-workspace--count)) + (accept-process-output nil 0.1))) + (setq exwm-workspace--fullscreen-frame-count nil)) + + + +(provide 'exwm-workspace) + +;;; exwm-workspace.el ends here diff --git a/third_party/exwm/exwm-xim.el b/third_party/exwm/exwm-xim.el new file mode 100644 index 0000000000..1f0c9c460b --- /dev/null +++ b/third_party/exwm/exwm-xim.el @@ -0,0 +1,810 @@ +;;; exwm-xim.el --- XIM Module for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 2019-2024 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module adds XIM support for EXWM and allows sending characters +;; generated by any Emacs's builtin input method (info node `Input Methods') +;; to X windows. + +;; This module is essentially an X input method server utilizing Emacs as +;; its backend. It talks with X windows through the XIM protocol. The XIM +;; protocol is quite flexible by itself, stating that an implementation can +;; create network connections of various types as well as make use of an +;; existing X connection for communication, and that an IM server may +;; support multiple transport versions, various input styles and several +;; event flow modals, etc. Here we only make choices that are most popular +;; among other IM servers and more importantly, practical for Emacs to act +;; as an IM server: +;; +;; + Packets are transported on top of an X connection like most IMEs. +;; + Only transport version 0.0 (i.e. only-CM & Property-with-CM) is +;; supported (same as "IM Server Developers Kit", adopted by most IMEs). +;; + Only support static event flow, on-demand-synchronous method. +;; + Only "root-window" input style is supported. + +;; To use this module, first load and enable it as follows: +;; +;; (require 'exwm-xim) +;; (exwm-xim-enable) +;; +;; A keybinding for `toggle-input-method' is probably required to turn on & +;; off an input method (default to `default-input-method'). It's bound to +;; 'C-\' by default and can be made reachable when working with X windows: +;; +;; (push ?\C-\\ exwm-input-prefix-keys) +;; +;; It's also required (and error-prone) to setup environment variables to +;; make applications actually use this input method. Typically the +;; following lines should be inserted into '~/.xinitrc'. +;; +;; export XMODIFIERS=@im=exwm-xim +;; export GTK_IM_MODULE=xim +;; export QT_IM_MODULE=xim +;; export CLUTTER_IM_MODULE=xim + +;; References: +;; + XIM (http://www.x.org/releases/X11R7.6/doc/libX11/specs/XIM/xim.html) +;; + IMdkit (http://xorg.freedesktop.org/archive/unsupported/lib/IMdkit/) +;; + UIM (https://github.com/uim/uim) + +;;; Code: + +(require 'cl-lib) + +(require 'xcb-keysyms) +(require 'xcb-xim) + +(require 'exwm-core) +(require 'exwm-input) + +(defconst exwm-xim--locales + "@locale=\ +aa,af,ak,am,an,anp,ar,as,ast,ayc,az,be,bem,ber,bg,bhb,bho,bn,bo,br,brx,bs,byn,\ +ca,ce,cmn,crh,cs,csb,cv,cy,da,de,doi,dv,dz,el,en,es,et,eu,fa,ff,fi,fil,fo,fr,\ +fur,fy,ga,gd,gez,gl,gu,gv,ha,hak,he,hi,hne,hr,hsb,ht,hu,hy,ia,id,ig,ik,is,it,\ +iu,iw,ja,ka,kk,kl,km,kn,ko,kok,ks,ku,kw,ky,lb,lg,li,li,lij,lo,lt,lv,lzh,mag,\ +mai,mg,mhr,mi,mk,ml,mn,mni,mr,ms,mt,my,nan,nb,nds,ne,nhn,niu,nl,nn,nr,nso,oc,\ +om,or,os,pa,pa,pap,pl,ps,pt,quz,raj,ro,ru,rw,sa,sat,sc,sd,se,shs,si,sid,sk,sl,\ +so,sq,sr,ss,st,sv,sw,szl,ta,tcy,te,tg,th,the,ti,tig,tk,tl,tn,tr,ts,tt,ug,uk,\ +unm,ur,uz,ve,vi,wa,wae,wal,wo,xh,yi,yo,yue,zh,zu,\ +C,no" + "All supported locales (stolen from glibc).") + +(defconst exwm-xim--default-error + (make-instance 'xim:error + :im-id 0 + :ic-id 0 + :flag xim:error-flag:invalid-both + :error-code xim:error-code:bad-something + :length 0 + :type 0 + :detail nil) + "Default error returned to clients.") + +(defconst exwm-xim--default-im-attrs + (list (make-instance 'xim:XIMATTR + :id 0 + :type xim:ATTRIBUTE-VALUE-TYPE:xim-styles + :length (length xlib:XNQueryInputStyle) + :attribute xlib:XNQueryInputStyle)) + "Default IM attrs returned to clients.") + +(defconst exwm-xim--default-ic-attrs + (list (make-instance 'xim:XICATTR + :id 0 + :type xim:ATTRIBUTE-VALUE-TYPE:long-data + :length (length xlib:XNInputStyle) + :attribute xlib:XNInputStyle) + (make-instance 'xim:XICATTR + :id 1 + :type xim:ATTRIBUTE-VALUE-TYPE:window + :length (length xlib:XNClientWindow) + :attribute xlib:XNClientWindow) + ;; Required by e.g. xterm. + (make-instance 'xim:XICATTR + :id 2 + :type xim:ATTRIBUTE-VALUE-TYPE:window + :length (length xlib:XNFocusWindow) + :attribute xlib:XNFocusWindow)) + "Default IC attrs returned to clients.") + +(defconst exwm-xim--default-styles + (make-instance 'xim:XIMStyles + :number nil + :styles (list (logior xlib:XIMPreeditNothing + xlib:XIMStatusNothing))) + "Default styles: root-window, i.e. no preediting or status display support.") + +(defconst exwm-xim--default-attributes + (list (make-instance 'xim:XIMATTRIBUTE + :id 0 + :length nil + :value exwm-xim--default-styles)) + "Default IM/IC attributes returned to clients.") + +(defvar exwm-xim--conn nil + "The X connection for initiating other XIM connections.") +(defvar exwm-xim--event-xwin nil + "X window for initiating new XIM connections.") +(defvar exwm-xim--server-client-plist '(nil nil) + "Plist mapping server window to [X connection, client window, byte-order].") +(defvar exwm-xim--client-server-plist '(nil nil) + "Plist mapping client window to server window.") +(defvar exwm-xim--property-index 0 "For generating a unique property name.") +(defvar exwm-xim--im-id 0 "Last IM ID.") +(defvar exwm-xim--ic-id 0 "Last IC ID.") + +;; X11 atoms. +(defvar exwm-xim--@server nil) +(defvar exwm-xim--LOCALES nil) +(defvar exwm-xim--TRANSPORT nil) +(defvar exwm-xim--XIM_SERVERS nil) +(defvar exwm-xim--_XIM_PROTOCOL nil) +(defvar exwm-xim--_XIM_XCONNECT nil) + +(defvar exwm-xim-buffer-p nil + "Whether current buffer is used by exwm-xim.") +(make-variable-buffer-local 'exwm-xim-buffer-p) + +(defun exwm-xim--on-SelectionRequest (data _synthetic) + "Handle SelectionRequest events on IMS window. +DATA contains unmarshalled SelectionRequest event data. + +Such events would be received when clients query for LOCALES or TRANSPORT." + (exwm--log) + (let ((evt (make-instance 'xcb:SelectionRequest)) + value fake-event) + (xcb:unmarshal evt data) + (with-slots (time requestor selection target property) evt + (setq value (cond ((= target exwm-xim--LOCALES) + ;; Return supported locales. + exwm-xim--locales) + ((= target exwm-xim--TRANSPORT) + ;; Use XIM over an X connection. + "@transport=X/"))) + (when value + ;; Change the property. + (xcb:+request exwm-xim--conn + (make-instance 'xcb:ChangeProperty + :mode xcb:PropMode:Replace + :window requestor + :property property + :type target + :format 8 + :data-len (length value) + :data value)) + ;; Send a SelectionNotify event. + (setq fake-event (make-instance 'xcb:SelectionNotify + :time time + :requestor requestor + :selection selection + :target target + :property property)) + (xcb:+request exwm-xim--conn + (make-instance 'xcb:SendEvent + :propagate 0 + :destination requestor + :event-mask xcb:EventMask:NoEvent + :event (xcb:marshal fake-event exwm-xim--conn))) + (xcb:flush exwm-xim--conn))))) + +(cl-defun exwm-xim--on-ClientMessage-0 (data _synthetic) + "Handle ClientMessage event on IMS window (new connection). + +Such events would be received when clients request for _XIM_XCONNECT. +A new X connection and server window would be created to communicate with +this client." + (exwm--log) + (let ((evt (make-instance 'xcb:ClientMessage)) + conn client-xwin server-xwin) + (xcb:unmarshal evt data) + (with-slots (window type data) evt + (unless (= type exwm-xim--_XIM_XCONNECT) + ;; Only handle _XIM_XCONNECT. + (exwm--log "Ignore ClientMessage %s" type) + (cl-return-from exwm-xim--on-ClientMessage-0)) + (setq client-xwin (elt (slot-value data 'data32) 0) + ;; Create a new X connection and a new server window. + conn (xcb:connect) + server-xwin (xcb:generate-id conn)) + (set-process-query-on-exit-flag (slot-value conn 'process) nil) + ;; Store this client. + (plist-put exwm-xim--server-client-plist server-xwin + `[,conn ,client-xwin nil]) + (plist-put exwm-xim--client-server-plist client-xwin server-xwin) + ;; Select DestroyNotify events on this client window. + (xcb:+request exwm-xim--conn + (make-instance 'xcb:ChangeWindowAttributes + :window client-xwin + :value-mask xcb:CW:EventMask + :event-mask xcb:EventMask:StructureNotify)) + (xcb:flush exwm-xim--conn) + ;; Handle ClientMessage events from this new connection. + (xcb:+event conn 'xcb:ClientMessage #'exwm-xim--on-ClientMessage) + ;; Create a communication window. + (xcb:+request conn + (make-instance 'xcb:CreateWindow + :depth 0 + :wid server-xwin + :parent exwm--root + :x 0 + :y 0 + :width 1 + :height 1 + :border-width 0 + :class xcb:WindowClass:InputOutput + :visual 0 + :value-mask xcb:CW:OverrideRedirect + :override-redirect 1)) + (xcb:flush conn) + ;; Send connection establishment ClientMessage. + (setf window client-xwin + (slot-value data 'data32) `(,server-xwin 0 0 0 0)) + (slot-makeunbound data 'data8) + (slot-makeunbound data 'data16) + (xcb:+request exwm-xim--conn + (make-instance 'xcb:SendEvent + :propagate 0 + :destination client-xwin + :event-mask xcb:EventMask:NoEvent + :event (xcb:marshal evt exwm-xim--conn))) + (xcb:flush exwm-xim--conn)))) + +(cl-defun exwm-xim--on-ClientMessage (data _synthetic) + "Handle ClientMessage event on IMS communication window (request). + +Such events would be received when clients request for _XIM_PROTOCOL. +The actual XIM request is in client message data or a property." + (exwm--log) + (let ((evt (make-instance 'xcb:ClientMessage)) + conn client-xwin server-xwin) + (xcb:unmarshal evt data) + (with-slots (format window type data) evt + (unless (= type exwm-xim--_XIM_PROTOCOL) + (exwm--log "Ignore ClientMessage %s" type) + (cl-return-from exwm-xim--on-ClientMessage)) + (setq server-xwin window + conn (plist-get exwm-xim--server-client-plist server-xwin) + client-xwin (elt conn 1) + conn (elt conn 0)) + (cond ((= format 8) + ;; Data. + (exwm-xim--on-request (vconcat (slot-value data 'data8)) + conn client-xwin server-xwin)) + ((= format 32) + ;; Atom. + (with-slots (data32) data + (with-slots (value) + (xcb:+request-unchecked+reply conn + (make-instance 'xcb:GetProperty + :delete 1 + :window server-xwin + :property (elt data32 1) + :type xcb:GetPropertyType:Any + :long-offset 0 + :long-length (elt data32 0))) + (when (> (length value) 0) + (exwm-xim--on-request value conn client-xwin + server-xwin))))))))) + +(defun exwm-xim--on-request (data conn client-xwin server-xwin) + "Handle an XIM reuqest." + (exwm--log) + (let ((opcode (elt data 0)) + ;; Let-bind `xim:lsb' to make pack/unpack functions work correctly. + (xim:lsb (elt (plist-get exwm-xim--server-client-plist server-xwin) 2)) + req replies) + (cond ((= opcode xim:opcode:error) + (exwm--log "ERROR: %s" data)) + ((= opcode xim:opcode:connect) + (exwm--log "CONNECT") + (setq xim:lsb (= (elt data 4) xim:connect-byte-order:lsb-first)) + ;; Store byte-order. + (setf (elt (plist-get exwm-xim--server-client-plist server-xwin) 2) + xim:lsb) + (setq req (make-instance 'xim:connect)) + (xcb:unmarshal req data) + (if (and (= (slot-value req 'major-version) 1) + (= (slot-value req 'minor-version) 0) + ;; Do not support authentication. + (= (slot-value req 'number) 0)) + ;; Accept the connection. + (push (make-instance 'xim:connect-reply) replies) + ;; Deny it. + (push exwm-xim--default-error replies))) + ((memq opcode (list xim:opcode:auth-required + xim:opcode:auth-reply + xim:opcode:auth-next + xim:opcode:auth-ng)) + (exwm--log "AUTH: %d" opcode) + ;; Deny any attempt to make authentication. + (push exwm-xim--default-error replies)) + ((= opcode xim:opcode:disconnect) + (exwm--log "DISCONNECT") + ;; Gracefully disconnect from the client. + (exwm-xim--make-request (make-instance 'xim:disconnect-reply) + conn client-xwin) + ;; Destroy the communication window & connection. + (xcb:+request conn + (make-instance 'xcb:DestroyWindow + :window server-xwin)) + (xcb:disconnect conn) + ;; Clean up cache. + (cl-remf exwm-xim--server-client-plist server-xwin) + (cl-remf exwm-xim--client-server-plist client-xwin)) + ((= opcode xim:opcode:open) + (exwm--log "OPEN") + ;; Note: We make no check here. + (setq exwm-xim--im-id (if (< exwm-xim--im-id #xffff) + (1+ exwm-xim--im-id) + 1)) + (setq replies + (list + (make-instance 'xim:open-reply + :im-id exwm-xim--im-id + :im-attrs-length nil + :im-attrs exwm-xim--default-im-attrs + :ic-attrs-length nil + :ic-attrs exwm-xim--default-ic-attrs) + (make-instance 'xim:set-event-mask + :im-id exwm-xim--im-id + :ic-id 0 + ;; Static event flow. + :forward-event-mask xcb:EventMask:KeyPress + ;; on-demand-synchronous method. + :synchronous-event-mask + xcb:EventMask:NoEvent)))) + ((= opcode xim:opcode:close) + (exwm--log "CLOSE") + (setq req (make-instance 'xim:close)) + (xcb:unmarshal req data) + (push (make-instance 'xim:close-reply + :im-id (slot-value req 'im-id)) + replies)) + ((= opcode xim:opcode:trigger-notify) + (exwm--log "TRIGGER-NOTIFY") + ;; Only static event flow modal is supported. + (push exwm-xim--default-error replies)) + ((= opcode xim:opcode:encoding-negotiation) + (exwm--log "ENCODING-NEGOTIATION") + (setq req (make-instance 'xim:encoding-negotiation)) + (xcb:unmarshal req data) + (let ((index (cl-position "COMPOUND_TEXT" + (mapcar (lambda (i) (slot-value i 'name)) + (slot-value req 'names)) + :test #'equal))) + (unless index + ;; Fallback to portable character encoding (a subset of ASCII). + (setq index -1)) + (push (make-instance 'xim:encoding-negotiation-reply + :im-id (slot-value req 'im-id) + :category + xim:encoding-negotiation-reply-category:name + :index index) + replies))) + ((= opcode xim:opcode:query-extension) + (exwm--log "QUERY-EXTENSION") + (setq req (make-instance 'xim:query-extension)) + (xcb:unmarshal req data) + (push (make-instance 'xim:query-extension-reply + :im-id (slot-value req 'im-id) + ;; No extension support. + :length 0 + :extensions nil) + replies)) + ((= opcode xim:opcode:set-im-values) + (exwm--log "SET-IM-VALUES") + ;; There's only one possible input method attribute. + (setq req (make-instance 'xim:set-im-values)) + (xcb:unmarshal req data) + (push (make-instance 'xim:set-im-values-reply + :im-id (slot-value req 'im-id)) + replies)) + ((= opcode xim:opcode:get-im-values) + (exwm--log "GET-IM-VALUES") + (setq req (make-instance 'xim:get-im-values)) + (let (im-attributes-id) + (xcb:unmarshal req data) + (setq im-attributes-id (slot-value req 'im-attributes-id)) + (if (cl-notevery (lambda (i) (= i 0)) im-attributes-id) + ;; Only support one IM attributes. + (push (make-instance 'xim:error + :im-id (slot-value req 'im-id) + :ic-id 0 + :flag xim:error-flag:invalid-ic-id + :error-code xim:error-code:bad-something + :length 0 + :type 0 + :detail nil) + replies) + (push + (make-instance 'xim:get-im-values-reply + :im-id (slot-value req 'im-id) + :length nil + :im-attributes exwm-xim--default-attributes) + replies)))) + ((= opcode xim:opcode:create-ic) + (exwm--log "CREATE-IC") + (setq req (make-instance 'xim:create-ic)) + (xcb:unmarshal req data) + ;; Note: The ic-attributes slot is ignored. + (setq exwm-xim--ic-id (if (< exwm-xim--ic-id #xffff) + (1+ exwm-xim--ic-id) + 1)) + (push (make-instance 'xim:create-ic-reply + :im-id (slot-value req 'im-id) + :ic-id exwm-xim--ic-id) + replies)) + ((= opcode xim:opcode:destroy-ic) + (exwm--log "DESTROY-IC") + (setq req (make-instance 'xim:destroy-ic)) + (xcb:unmarshal req data) + (push (make-instance 'xim:destroy-ic-reply + :im-id (slot-value req 'im-id) + :ic-id (slot-value req 'ic-id)) + replies)) + ((= opcode xim:opcode:set-ic-values) + (exwm--log "SET-IC-VALUES") + (setq req (make-instance 'xim:set-ic-values)) + (xcb:unmarshal req data) + ;; We don't distinguish between input contexts. + (push (make-instance 'xim:set-ic-values-reply + :im-id (slot-value req 'im-id) + :ic-id (slot-value req 'ic-id)) + replies)) + ((= opcode xim:opcode:get-ic-values) + (exwm--log "GET-IC-VALUES") + (setq req (make-instance 'xim:get-ic-values)) + (xcb:unmarshal req data) + (push (make-instance 'xim:get-ic-values-reply + :im-id (slot-value req 'im-id) + :ic-id (slot-value req 'ic-id) + :length nil + :ic-attributes exwm-xim--default-attributes) + replies)) + ((= opcode xim:opcode:set-ic-focus) + (exwm--log "SET-IC-FOCUS") + ;; All input contexts are the same. + ) + ((= opcode xim:opcode:unset-ic-focus) + (exwm--log "UNSET-IC-FOCUS") + ;; All input contexts are the same. + ) + ((= opcode xim:opcode:forward-event) + (exwm--log "FORWARD-EVENT") + (setq req (make-instance 'xim:forward-event)) + (xcb:unmarshal req data) + (exwm-xim--handle-forward-event-request req xim:lsb conn + client-xwin)) + ((= opcode xim:opcode:sync) + (exwm--log "SYNC") + (setq req (make-instance 'xim:sync)) + (xcb:unmarshal req data) + (push (make-instance 'xim:sync-reply + :im-id (slot-value req 'im-id) + :ic-id (slot-value req 'ic-id)) + replies)) + ((= opcode xim:opcode:sync-reply) + (exwm--log "SYNC-REPLY")) + ((= opcode xim:opcode:reset-ic) + (exwm--log "RESET-IC") + ;; No context-specific data saved. + (setq req (make-instance 'xim:reset-ic)) + (xcb:unmarshal req data) + (push (make-instance 'xim:reset-ic-reply + :im-id (slot-value req 'im-id) + :ic-id (slot-value req 'ic-id) + :length 0 + :string "") + replies)) + ((memq opcode (list xim:opcode:str-conversion-reply + xim:opcode:preedit-start-reply + xim:opcode:preedit-caret-reply)) + (exwm--log "PREEDIT: %d" opcode) + ;; No preedit support. + (push exwm-xim--default-error replies)) + (t + (exwm--log "Bad protocol") + (push exwm-xim--default-error replies))) + ;; Actually send the replies. + (when replies + (mapc (lambda (reply) + (exwm-xim--make-request reply conn client-xwin)) + replies) + (xcb:flush conn)))) + +(defun exwm-xim--handle-forward-event-request (req lsb conn client-xwin) + (let ((im-func (with-current-buffer (window-buffer) + input-method-function)) + key-event keysym keysyms event result) + ;; Note: The flag slot is ignored. + ;; Do conversion in client's byte-order. + (let ((xcb:lsb lsb)) + (setq key-event (make-instance 'xcb:KeyPress)) + (xcb:unmarshal key-event (slot-value req 'event))) + (with-slots (detail state) key-event + (setq keysym (xcb:keysyms:keycode->keysym exwm-xim--conn detail + state)) + (when (/= (car keysym) 0) + (setq event (xcb:keysyms:keysym->event + exwm-xim--conn + (car keysym) + (logand state (lognot (cdr keysym))))))) + (while (or (slot-value req 'event) unread-command-events) + (unless (slot-value req 'event) + (setq event (pop unread-command-events)) + ;; Handle events in (t . EVENT) format. + (when (and (consp event) + (eq (car event) t)) + (setq event (cdr event)))) + (if (or (not im-func) + ;; `list' is the default method. + (eq im-func #'list) + (not event) + ;; Select only printable keys. + (not (integerp event)) (> #x20 event) (< #x7e event)) + ;; Either there is no active input method, or invalid key + ;; is detected. + (with-slots ((raw-event event) + im-id ic-id serial-number) + req + (if raw-event + (setq event raw-event) + (setq keysyms (xcb:keysyms:event->keysyms exwm-xim--conn event)) + (with-slots (detail state) key-event + (setf detail (xcb:keysyms:keysym->keycode exwm-xim--conn + (caar keysyms)) + state (cdar keysyms))) + (setq event (let ((xcb:lsb lsb)) + (xcb:marshal key-event conn)))) + (when event + (exwm-xim--make-request + (make-instance 'xim:forward-event + :im-id im-id + :ic-id ic-id + :flag xim:commit-flag:synchronous + :serial-number serial-number + :event event) + conn client-xwin))) + (when (eq exwm--selected-input-mode 'char-mode) + ;; Grab keyboard temporarily for char-mode. + (exwm-input--grab-keyboard)) + (unwind-protect + (with-temp-buffer + ;; This variable is used to test whether exwm-xim is enabled. + ;; Used by e.g. pyim-probe. + (setq-local exwm-xim-buffer-p t) + ;; Always show key strokes. + (let ((input-method-use-echo-area t) + (exwm-input-line-mode-passthrough t)) + (setq result (funcall im-func event)) + ;; Clear echo area for the input method. + (message nil) + ;; This also works for portable character encoding. + (setq result + (encode-coding-string (concat result) + 'compound-text-with-extensions)) + (exwm-xim--make-request + (make-instance 'xim:commit-x-lookup-chars + :im-id (slot-value req 'im-id) + :ic-id (slot-value req 'ic-id) + :flag (logior xim:commit-flag:synchronous + xim:commit-flag:x-lookup-chars) + :length (length result) + :string result) + conn client-xwin))) + (when (eq exwm--selected-input-mode 'char-mode) + (exwm-input--release-keyboard)))) + (xcb:flush conn) + (setf event nil + (slot-value req 'event) nil)))) + +(defun exwm-xim--make-request (req conn client-xwin) + "Make an XIM request REQ via connection CONN. + +CLIENT-XWIN would receive a ClientMessage event either telling the client +the request data or where to fetch the data." + (exwm--log) + (let ((data (xcb:marshal req)) + property format client-message-data client-message) + (if (<= (length data) 20) + ;; Send short requests directly with client messages. + (setq format 8 + ;; Pad to 20 bytes. + data (append data (make-list (- 20 (length data)) 0)) + client-message-data (make-instance 'xcb:ClientMessageData + :data8 data)) + ;; Send long requests with properties. + (setq property (exwm--intern-atom (format "_EXWM_XIM_%x" + exwm-xim--property-index))) + (cl-incf exwm-xim--property-index) + (xcb:+request conn + (make-instance 'xcb:ChangeProperty + :mode xcb:PropMode:Append + :window client-xwin + :property property + :type xcb:Atom:STRING + :format 8 + :data-len (length data) + :data data)) + ;; Also send a client message to notify the client about this property. + (setq format 32 + client-message-data (make-instance 'xcb:ClientMessageData + :data32 `(,(length data) + ,property + ;; Pad to 20 bytes. + 0 0 0)))) + ;; Send the client message. + (setq client-message (make-instance 'xcb:ClientMessage + :format format + :window client-xwin + :type exwm-xim--_XIM_PROTOCOL + :data client-message-data)) + (xcb:+request conn + (make-instance 'xcb:SendEvent + :propagate 0 + :destination client-xwin + :event-mask xcb:EventMask:NoEvent + :event (xcb:marshal client-message conn))))) + +(defun exwm-xim--on-DestroyNotify (data synthetic) + "Do cleanups on receiving DestroyNotify event. + +Such event would be received when the client window is destroyed." + (exwm--log) + (unless synthetic + (let ((evt (make-instance 'xcb:DestroyNotify)) + conn client-xwin server-xwin) + (xcb:unmarshal evt data) + (setq client-xwin (slot-value evt 'window) + server-xwin (plist-get exwm-xim--client-server-plist client-xwin)) + (when server-xwin + (setq conn (aref (plist-get exwm-xim--server-client-plist server-xwin) + 0)) + (cl-remf exwm-xim--server-client-plist server-xwin) + (cl-remf exwm-xim--client-server-plist client-xwin) + ;; Destroy the communication window & connection. + (xcb:+request conn + (make-instance 'xcb:DestroyWindow + :window server-xwin)) + (xcb:disconnect conn))))) + +(cl-defun exwm-xim--init () + "Initialize the XIM module." + (exwm--log) + (when exwm-xim--conn + (cl-return-from exwm-xim--init)) + ;; Initialize atoms. + (setq exwm-xim--@server (exwm--intern-atom "@server=exwm-xim") + exwm-xim--LOCALES (exwm--intern-atom "LOCALES") + exwm-xim--TRANSPORT (exwm--intern-atom "TRANSPORT") + exwm-xim--XIM_SERVERS (exwm--intern-atom "XIM_SERVERS") + exwm-xim--_XIM_PROTOCOL (exwm--intern-atom "_XIM_PROTOCOL") + exwm-xim--_XIM_XCONNECT (exwm--intern-atom "_XIM_XCONNECT")) + ;; Create a new connection and event window. + (setq exwm-xim--conn (xcb:connect) + exwm-xim--event-xwin (xcb:generate-id exwm-xim--conn)) + (set-process-query-on-exit-flag (slot-value exwm-xim--conn 'process) nil) + ;; Initialize xcb:keysyms module. + (xcb:keysyms:init exwm-xim--conn) + ;; Listen to SelectionRequest event for connection establishment. + (xcb:+event exwm-xim--conn 'xcb:SelectionRequest + #'exwm-xim--on-SelectionRequest) + ;; Listen to ClientMessage event on IMS window for new XIM connection. + (xcb:+event exwm-xim--conn 'xcb:ClientMessage #'exwm-xim--on-ClientMessage-0) + ;; Listen to DestroyNotify event to do cleanups. + (xcb:+event exwm-xim--conn 'xcb:DestroyNotify #'exwm-xim--on-DestroyNotify) + ;; Create the event window. + (xcb:+request exwm-xim--conn + (make-instance 'xcb:CreateWindow + :depth 0 + :wid exwm-xim--event-xwin + :parent exwm--root + :x 0 + :y 0 + :width 1 + :height 1 + :border-width 0 + :class xcb:WindowClass:InputOutput + :visual 0 + :value-mask xcb:CW:OverrideRedirect + :override-redirect 1)) + ;; Set the selection owner. + (xcb:+request exwm-xim--conn + (make-instance 'xcb:SetSelectionOwner + :owner exwm-xim--event-xwin + :selection exwm-xim--@server + :time xcb:Time:CurrentTime)) + ;; Set XIM_SERVERS property on the root window. + (xcb:+request exwm-xim--conn + (make-instance 'xcb:ChangeProperty + :mode xcb:PropMode:Prepend + :window exwm--root + :property exwm-xim--XIM_SERVERS + :type xcb:Atom:ATOM + :format 32 + :data-len 1 + :data (funcall (if xcb:lsb + #'xcb:-pack-u4-lsb + #'xcb:-pack-u4) + exwm-xim--@server))) + (xcb:flush exwm-xim--conn)) + +(cl-defun exwm-xim--exit () + "Exit the XIM module." + (exwm--log) + ;; Close IMS communication connections. + (mapc (lambda (i) + (when (vectorp i) + (when (slot-value (elt i 0) 'connected) + (xcb:disconnect (elt i 0))))) + exwm-xim--server-client-plist) + ;; Close the IMS connection. + (unless (and exwm-xim--conn + (slot-value exwm-xim--conn 'connected)) + (cl-return-from exwm-xim--exit)) + ;; Remove exwm-xim from XIM_SERVERS. + (let ((reply (xcb:+request-unchecked+reply exwm-xim--conn + (make-instance 'xcb:GetProperty + :delete 1 + :window exwm--root + :property exwm-xim--XIM_SERVERS + :type xcb:Atom:ATOM + :long-offset 0 + :long-length 1000))) + unpacked-reply pack unpack) + (unless reply + (cl-return-from exwm-xim--exit)) + (setq reply (slot-value reply 'value)) + (unless (> (length reply) 4) + (cl-return-from exwm-xim--exit)) + (setq reply (vconcat reply) + pack (if xcb:lsb #'xcb:-pack-u4-lsb #'xcb:-pack-u4) + unpack (if xcb:lsb #'xcb:-unpack-u4-lsb #'xcb:-unpack-u4)) + (dotimes (i (/ (length reply) 4)) + (push (funcall unpack reply (* i 4)) unpacked-reply)) + (setq unpacked-reply (delq exwm-xim--@server unpacked-reply) + reply (mapcar pack unpacked-reply)) + (xcb:+request exwm-xim--conn + (make-instance 'xcb:ChangeProperty + :mode xcb:PropMode:Replace + :window exwm--root + :property exwm-xim--XIM_SERVERS + :type xcb:Atom:ATOM + :format 32 + :data-len (length reply) + :data reply)) + (xcb:flush exwm-xim--conn)) + (xcb:disconnect exwm-xim--conn) + (setq exwm-xim--conn nil)) + +(defun exwm-xim-enable () + "Enable XIM support for EXWM." + (exwm--log) + (add-hook 'exwm-init-hook #'exwm-xim--init) + (add-hook 'exwm-exit-hook #'exwm-xim--exit)) + + + +(provide 'exwm-xim) + +;;; exwm-xim.el ends here diff --git a/third_party/exwm/exwm-xsettings.el b/third_party/exwm/exwm-xsettings.el new file mode 100644 index 0000000000..99d6b9c4ac --- /dev/null +++ b/third_party/exwm/exwm-xsettings.el @@ -0,0 +1,336 @@ +;;; exwm-xsettings.el --- XSETTINGS Module for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 2022-2024 Free Software Foundation, Inc. + +;; Author: Steven Allen <steven@stebalien.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Implements the XSETTINGS protocol, allowing Emacs to manage the system theme, +;; fonts, icons, etc. +;; +;; This package can be configured as follows: +;; +;; (require 'exwm-xsettings) +;; (setq exwm-xsettings-theme '("Adwaita" . "Adwaita-dark") ;; light/dark +;; exwm-xsettings `(("Xft/HintStyle" . "hintslight") +;; ("Xft/RGBA" . "rgb") +;; ("Xft/lcdfilter" . "lcddefault") +;; ("Xft/Antialias" . 1) +;; ;; DPI is in 1024ths of an inch, so this is a DPI of +;; ;; 144, equivalent to ;; a scaling factor of 1.5 +;; ;; (144 = 1.5 * 96). +;; ("Xft/DPI" . ,(* 144 1024)) +;; ("Xft/Hinting" . 1))) +;; (exwm-xsettings-enable) +;; +;; To modify these settings at runtime, customize them with +;; `custom-set-variables' or `setopt' (Emacs 29+). E.g., the following will +;; immediately change the icon theme to "Papirus" at runtime, even in running +;; applications: +;; +;; (setopt exwm-xsettings-icon-theme "Papirus") + +;;; Code: + +(require 'xcb-ewmh) +(require 'xcb-xsettings) +(require 'exwm-core) + +(defvar exwm-xsettings--connection nil) +(defvar exwm-xsettings--XSETTINGS_SETTINGS-atom nil) +(defvar exwm-xsettings--XSETTINGS_S0-atom nil) +(defvar exwm-xsettings--selection-owner-window nil) +(defvar exwm-xsettings--serial 0) + +(defun exwm-xsettings--rgba-match (_widget value) + "Return t if VALUE is a valid RGBA color." + (and (numberp value) (<= 0 value 1))) + +(defun exwm-xsettings--custom-set (symbol value) + "Setter used by `exwm-xsettings' customization options. + +SYMBOL is the setting being updated and VALUE is the new value." + (set-default-toplevel-value symbol value) + (exwm-xsettings--update-settings)) + +(defgroup exwm-xsettings nil + "XSETTINGS." + :group 'exwm) + +(defcustom exwm-xsettings nil + "Alist of custom XSETTINGS. +These settings take precedence over `exwm-xsettings-theme' and +`exwm-xsettings-icon-theme'." + :type '(alist :key-type (string :tag "Name") + :value-type (choice :tag "Value" + (string :tag "String") + (integer :tag "Integer") + (list :tag "Color" + (number :tag "Red" + :type-error + "This field should contain a number between 0 and 1." + :match exwm-xsettings--rgba-match) + (number :tag "Green" + :type-error + "This field should contain a number between 0 and 1." + :match exwm-xsettings--rgba-match) + (number :tag "Blue" + :type-error + "This field should contain a number between 0 and 1." + :match exwm-xsettings--rgba-match) + (number :tag "Alpha" + :type-error + "This field should contain a number between 0 and 1." + :match exwm-xsettings--rgba-match + :value 1.0)))) + :initialize #'custom-initialize-default + :set #'exwm-xsettings--custom-set) + +(defcustom exwm-xsettings-theme nil + "The system-wide theme." + :type '(choice (string :tag "Theme") + (cons (string :tag "Light Theme") + (string :tag "Dark Theme"))) + :initialize #'custom-initialize-default + :set #'exwm-xsettings--custom-set) + +(defcustom exwm-xsettings-icon-theme nil + "The system-wide icon theme." + :type '(choice (string :tag "Icon Theme") + (cons (string :tag "Light Icon Theme") + (string :tag "Dark Icon Theme"))) + :initialize #'custom-initialize-default + :set #'exwm-xsettings--custom-set) + +(defalias 'exwm-xsettings--color-dark-p + (if (eval-when-compile (< emacs-major-version 29)) + ;; Borrowed from Emacs 29. + (lambda (rgb) + "Whether RGB is more readable against white than black." + (unless (<= 0 (apply #'min rgb) (apply #'max rgb) 1) + (error "RGB components %S not in [0,1]" rgb)) + (let* ((r (expt (nth 0 rgb) 2.2)) + (g (expt (nth 1 rgb) 2.2)) + (b (expt (nth 2 rgb) 2.2)) + (y (+ (* r 0.2126) (* g 0.7152) (* b 0.0722)))) + (< y 0.325))) + 'color-dark-p)) + +(defun exwm-xsettings--pick-theme (theme) + "Pick a light or dark theme from the given THEME. +If THEME is a string, it's returned directly. +If THEME is a cons of (LIGHT . DARK), the appropriate theme is picked based on +the default face's background color." + (pcase theme + ((cl-type string) theme) + (`(,(cl-type string) . ,(cl-type string)) + (if (exwm-xsettings--color-dark-p (color-name-to-rgb (face-background 'default))) + (cdr theme) (car theme))) + (_ (error "Expected theme to be a string or a pair of strings")))) + +(defun exwm-xsettings--get-settings () + "Get the current settings. +Combines `exwm-xsettings', `exwm-xsettings-theme' (if set), and +`exwm-xsettings-icon-theme' (if set)." + (cl-remove-duplicates + (append + exwm-xsettings + (when exwm-xsettings-theme + (list (cons "Net/ThemeName" (exwm-xsettings--pick-theme exwm-xsettings-theme)))) + (when exwm-xsettings-icon-theme + (list (cons "Net/IconThemeName" (exwm-xsettings--pick-theme exwm-xsettings-icon-theme))))) + :key 'car + :test 'string=)) + +(defun exwm-xsettings--make-settings (settings serial) + "Construct a new settings object. +SETTINGS is an alist of key/value pairs. +SERIAL is a sequence number." + (make-instance 'xcb:xsettings:-Settings + :byte-order (if xcb:lsb 0 1) + :serial serial + :settings-len (length settings) + :settings + (mapcar + (lambda (prop) + (let* ((name (car prop)) + (value (cdr prop)) + (common (list :name name + :name-len (length name) + :last-change-serial serial))) + (pcase value + ((cl-type string) + (apply #'make-instance 'xcb:xsettings:-SETTING_STRING + :value-len (length value) + :value value + common)) + ((cl-type integer) + (apply #'make-instance 'xcb:xsettings:-SETTING_INTEGER + :value value common)) + ((and (cl-type list) (app length (or 3 4))) + ;; Convert from RGB(A) to 16bit integers. + (setq value (mapcar (lambda (x) (round (* x #xffff))) value)) + (apply #'make-instance 'xcb:xsettings:-SETTING_COLOR + :red (pop value) + :green (pop value) + :blue (pop value) + :alpha (or (pop value) #xffff))) + (_ (error "Setting value must be a string, integer, or length 3-4 list"))))) + settings))) + +(defun exwm-xsettings--update-settings () + "Update the xsettings." + (when exwm-xsettings--connection + (setq exwm-xsettings--serial (1+ exwm-xsettings--serial)) + (let* ((settings (exwm-xsettings--get-settings)) + (bytes (xcb:marshal (exwm-xsettings--make-settings settings exwm-xsettings--serial)))) + (xcb:+request exwm-xsettings--connection + (make-instance 'xcb:ChangeProperty + :mode xcb:PropMode:Replace + :window exwm-xsettings--selection-owner-window + :property exwm-xsettings--XSETTINGS_SETTINGS-atom + :type exwm-xsettings--XSETTINGS_SETTINGS-atom + :format 8 + :data-len (length bytes) + :data bytes))) + (xcb:flush exwm-xsettings--connection))) + +(defun exwm-xsettings--on-theme-change (&rest _) + "Called when the Emacs theme is changed." + ;; We only bother updating the xsettings if changing the theme could effect + ;; the settings. + (when (or (consp exwm-xsettings-theme) (consp exwm-xsettings-icon-theme)) + (exwm-xsettings--update-settings))) + +(defun exwm-xsettings--on-SelectionClear (_data _synthetic) + "Called when another xsettings daemon takes over." + (exwm--log "XSETTINGS manager has been replaced.") + (exwm-xsettings--exit)) + +(cl-defun exwm-xsettings--init () + "Initialize the XSETTINGS module." + (exwm--log) + + (cl-assert (not exwm-xsettings--connection)) + + ;; Connect + (setq exwm-xsettings--connection (xcb:connect)) + (set-process-query-on-exit-flag (slot-value exwm-xsettings--connection + 'process) + nil) + + ;; Intern the atoms. + (setq exwm-xsettings--XSETTINGS_SETTINGS-atom + (exwm--intern-atom "_XSETTINGS_SETTINGS" exwm-xsettings--connection) + + exwm-xsettings--XSETTINGS_S0-atom + (exwm--intern-atom "_XSETTINGS_S0" exwm-xsettings--connection)) + + ;; Detect running XSETTINGS managers. + (with-slots (owner) + (xcb:+request-unchecked+reply exwm-xsettings--connection + (make-instance 'xcb:GetSelectionOwner + :selection exwm-xsettings--XSETTINGS_S0-atom)) + (when (/= owner xcb:Window:None) + (xcb:disconnect exwm-xsettings--connection) + (setq exwm-xsettings--connection nil) + (warn "[EXWM] Other XSETTINGS manager detected") + (cl-return-from exwm-xsettings--init))) + + (let ((id(xcb:generate-id exwm-xsettings--connection))) + (setq exwm-xsettings--selection-owner-window id) + + ;; Create a settings window. + (xcb:+request exwm-xsettings--connection + (make-instance 'xcb:CreateWindow + :wid id + :parent exwm--root + :class xcb:WindowClass:InputOnly + :x 0 + :y 0 + :width 1 + :height 1 + :border-width 0 + :depth 0 + :visual 0 + :value-mask xcb:CW:OverrideRedirect + :override-redirect 1)) + + ;; Set _NET_WM_NAME. + (xcb:+request exwm-xsettings--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window id + :data "EXWM: exwm-xsettings--selection-owner-window")) + + ;; Apply the XSETTINGS properties. + (exwm-xsettings--update-settings) + + ;; Take ownership and notify. + (xcb:+request exwm-xsettings--connection + (make-instance 'xcb:SetSelectionOwner + :owner id + :selection exwm-xsettings--XSETTINGS_S0-atom + :time xcb:Time:CurrentTime)) + (xcb:+request exwm-xsettings--connection + (make-instance 'xcb:SendEvent + :propagate 0 + :destination exwm--root + :event-mask xcb:EventMask:StructureNotify + :event (xcb:marshal + (make-instance 'xcb:xsettings:-ClientMessage + :window exwm--root + :time xcb:Time:CurrentTime + :selection exwm-xsettings--XSETTINGS_S0-atom + :owner id) + exwm-xsettings--connection))) + + ;; Detect loss of XSETTINGS ownership. + (xcb:+event exwm-xsettings--connection 'xcb:SelectionClear + #'exwm-xsettings--on-SelectionClear) + + (xcb:flush exwm-xsettings--connection)) + + ;; Update the xsettings if/when the theme changes. + (add-hook 'enable-theme-functions #'exwm-xsettings--on-theme-change) + (add-hook 'disable-theme-functions #'exwm-xsettings--on-theme-change)) + +(defun exwm-xsettings--exit () + "Exit the XSETTINGS module." + (exwm--log) + + (when exwm-xsettings--connection + (remove-hook 'enable-theme-functions #'exwm-xsettings--on-theme-change) + (remove-hook 'disable-theme-functions #'exwm-xsettings--on-theme-change) + + (xcb:disconnect exwm-xsettings--connection) + + (setq exwm-xsettings--connection nil + exwm-xsettings--XSETTINGS_SETTINGS-atom nil + exwm-xsettings--XSETTINGS_S0-atom nil + exwm-xsettings--selection-owner-window nil))) + +(defun exwm-xsettings-enable () + "Enable xsettings support for EXWM." + (exwm--log) + (add-hook 'exwm-init-hook #'exwm-xsettings--init) + (add-hook 'exwm-exit-hook #'exwm-xsettings--exit)) + +(provide 'exwm-xsettings) + +;;; exwm-xsettings.el ends here diff --git a/third_party/exwm/exwm.el b/third_party/exwm/exwm.el new file mode 100644 index 0000000000..c4900eab48 --- /dev/null +++ b/third_party/exwm/exwm.el @@ -0,0 +1,1113 @@ +;;; exwm.el --- Emacs X Window Manager -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2024 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> +;; Maintainer: Adrián Medraño Calvo <adrian@medranocalvo.com>, Steven Allen <steven@stebalien.com>, Daniel Mendler <mail@daniel-mendler.de> +;; Version: 0.28 +;; Package-Requires: ((emacs "27.1") (xelb "0.18")) +;; Keywords: unix +;; URL: https://github.com/emacs-exwm/exwm + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Overview +;; -------- +;; EXWM (Emacs X Window Manager) is a full-featured tiling X window manager +;; for Emacs built on top of [XELB](https://github.com/emacs-exwm/xelb). +;; It features: +;; + Fully keyboard-driven operations +;; + Hybrid layout modes (tiling & stacking) +;; + Dynamic workspace support +;; + ICCCM/EWMH compliance +;; Optional features: +;; + RandR (multi-monitor) support +;; + System tray +;; + Input method +;; + Background setting support +;; + XSETTINGS server + +;; Installation & configuration +;; ---------------------------- +;; Here are the minimal steps to get EXWM working: +;; 1. Install XELB and EXWM, and make sure they are in `load-path'. +;; 2. In '~/.emacs', add following lines (please modify accordingly): +;; +;; (require 'exwm) +;; (require 'exwm-config) +;; (exwm-config-example) +;; +;; 3. Link or copy the file 'xinitrc' to '~/.xinitrc'. +;; 4. Launch EXWM in a console (e.g. tty1) with +;; +;; xinit -- vt01 +;; +;; You should additionally hide the menu-bar, tool-bar, etc to increase the +;; usable space. Please check the wiki (https://github.com/emacs-exwm/exwm/wiki) +;; for more detailed instructions on installation, configuration, usage, etc. + +;; References: +;; + dwm (http://dwm.suckless.org/) +;; + i3 wm (https://i3wm.org/) +;; + Also see references within each required library. + +;;; Code: + +(require 'server) +(require 'exwm-core) +(require 'exwm-workspace) +(require 'exwm-layout) +(require 'exwm-floating) +(require 'exwm-manage) +(require 'exwm-input) + +(declare-function x-get-atom-name "C source code" (VALUE &optional FRAME)) + +(defgroup exwm nil + "Emacs X Window Manager." + :tag "EXWM" + :group 'applications + :prefix "exwm-") + +(defcustom exwm-init-hook nil + "Normal hook run when EXWM has just finished initialization." + :type 'hook) + +(defcustom exwm-exit-hook nil + "Normal hook run just before EXWM exits." + :type 'hook) + +(defcustom exwm-update-class-hook nil + "Normal hook run when window class is updated." + :type 'hook) + +(defcustom exwm-update-title-hook nil + "Normal hook run when window title is updated." + :type 'hook) + +(defcustom exwm-blocking-subrs + ;; `x-file-dialog' and `x-select-font' are missing on some Emacs builds, for + ;; example on the X11 Lucid build. + '(x-file-dialog x-popup-dialog x-select-font message-box message-or-box) + "Subrs (primitives) that would normally block EXWM." + :type '(repeat function)) + +(defcustom exwm-replace 'ask + "Whether to replace existing window manager." + :type '(radio (const :tag "Ask" ask) + (const :tag "Replace by default" t) + (const :tag "Do not replace" nil))) + +(defconst exwm--server-name "server-exwm" + "Name of the subordinate Emacs server.") + +(defvar exwm--server-timeout 1 + "Number of seconds to wait for the subordinate Emacs server to exit. +After this time, the server will be killed.") + +(defvar exwm--server-process nil "Process of the subordinate Emacs server.") + +(defun exwm-reset () + "Reset the state of the selected window (non-fullscreen, line-mode, etc)." + (interactive) + (exwm--log) + (with-current-buffer (window-buffer) + (when (derived-mode-p 'exwm-mode) + (when (exwm-layout--fullscreen-p) + (exwm-layout-unset-fullscreen)) + ;; Force refresh + (exwm-layout--refresh) + (call-interactively #'exwm-input-grab-keyboard)))) + +;;;###autoload +(defun exwm-restart () + "Restart EXWM." + (interactive) + (exwm--log) + (when (exwm--confirm-kill-emacs "Restart?" 'no-check) + (let* ((attr (process-attributes (emacs-pid))) + (args (cdr (assq 'args attr))) + (ppid (cdr (assq 'ppid attr))) + (pargs (cdr (assq 'args (process-attributes ppid))))) + (cond + ((= ppid 1) + ;; The parent is the init process. This probably means this + ;; instance is an emacsclient. Anyway, start a control instance + ;; to manage the subsequent ones. + (call-process (car command-line-args)) + (kill-emacs)) + ((string= args pargs) + ;; This is a subordinate instance. Return a magic number to + ;; inform the parent (control instance) to start another one. + (kill-emacs ?R)) + (t + ;; This is the control instance. Keep starting subordinate + ;; instances until told to exit. + ;; Run `server-force-stop' if it exists. + (run-hooks 'kill-emacs-hook) + (with-temp-buffer + (while (= ?R (shell-command-on-region (point) (point) args)))) + (kill-emacs)))))) + +(defun exwm--update-desktop (xwin) + "Update _NET_WM_DESKTOP. +Argument XWIN contains the X window of the `exwm-mode' buffer." + (exwm--log "#x%x" xwin) + (with-current-buffer (exwm--id->buffer xwin) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:ewmh:get-_NET_WM_DESKTOP + :window xwin))) + desktop) + (when reply + (setq desktop (slot-value reply 'value)) + (cond + ((and desktop (= desktop 4294967295.)) + (unless (or (not exwm--floating-frame) + (eq exwm--frame exwm-workspace--current) + (and exwm--desktop + (= desktop exwm--desktop))) + (exwm-layout--show xwin (frame-root-window exwm--floating-frame))) + (setq exwm--desktop desktop)) + ((and desktop + (< desktop (exwm-workspace--count)) + (if exwm--desktop + (/= desktop exwm--desktop) + (/= desktop (exwm-workspace--position exwm--frame)))) + (exwm-workspace-move-window desktop xwin)) + (t + (exwm-workspace--set-desktop xwin))))))) + +(defun exwm--update-window-type (id &optional force) + "Update `exwm-window-type' from _NET_WM_WINDOW_TYPE. +Argument ID contains the X window of the `exwm-mode' buffer. + +When FORCE is nil the update only takes place if +`exwm-window-type' is unset." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (and exwm-window-type (not force)) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:ewmh:get-_NET_WM_WINDOW_TYPE + :window id)))) + (when reply ;nil when destroyed + (setq exwm-window-type (append (slot-value reply 'value) nil))))))) + +(defun exwm--update-class (id &optional force) + "Update `exwm-instance-name' and `exwm-class' from WM_CLASS. +Argument ID contains the X window of the `exwm-mode' buffer. + +When FORCE is nil the update only takes place if any of +`exwm-instance-name' or `exwm-class' is unset." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (and exwm-instance-name exwm-class-name (not force)) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:icccm:get-WM_CLASS :window id)))) + (when reply ;nil when destroyed + (setq exwm-instance-name (slot-value reply 'instance-name) + exwm-class-name (slot-value reply 'class-name)) + (when (and exwm-instance-name exwm-class-name) + (run-hooks 'exwm-update-class-hook))))))) + +(defun exwm--update-utf8-title (id &optional force) + "Update `exwm-title' from _NET_WM_NAME. +Argument ID contains the X window of the `exwm-mode' buffer. + +When FORCE is nil the update only takes place if `exwm-title' is +unset." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (when (or force (not exwm-title)) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:ewmh:get-_NET_WM_NAME :window id)))) + (when reply ;nil when destroyed + (setq exwm-title (slot-value reply 'value)) + (when exwm-title + (setq exwm--title-is-utf8 t) + (run-hooks 'exwm-update-title-hook))))))) + +(defun exwm--update-ctext-title (id &optional force) + "Update `exwm-title' from WM_NAME. +Argument ID contains the X window of the `exwm-mode' buffer. + +When FORCE is nil the update only takes place if `exwm-title' is +unset." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (or exwm--title-is-utf8 + (and exwm-title (not force))) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:icccm:get-WM_NAME :window id)))) + (when reply ;nil when destroyed + (setq exwm-title (slot-value reply 'value)) + (when exwm-title + (run-hooks 'exwm-update-title-hook))))))) + +(defun exwm--update-title (id) + "Update _NET_WM_NAME or WM_NAME. +Argument ID contains the X window of the `exwm-mode' buffer." + (exwm--log "#x%x" id) + (exwm--update-utf8-title id) + (exwm--update-ctext-title id)) + +(defun exwm--update-transient-for (id &optional force) + "Update `exwm-transient-for' from WM_TRANSIENT_FOR. +Argument ID contains the X window of the `exwm-mode' buffer. + +When FORCE is nil the update only takes place if `exwm-title' is +unset." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (and exwm-transient-for (not force)) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:icccm:get-WM_TRANSIENT_FOR + :window id)))) + (when reply ;nil when destroyed + (setq exwm-transient-for (slot-value reply 'value))))))) + +(defun exwm--update-normal-hints (id &optional force) + "Update normal hints from WM_NORMAL_HINTS. +Argument ID contains the X window of the `exwm-mode' buffer. + +When FORCE is nil the update only takes place all of +`exwm--normal-hints-x exwm--normal-hints-y', +`exwm--normal-hints-width exwm--normal-hints-height', +`exwm--normal-hints-min-width exwm--normal-hints-min-height' and +`exwm--normal-hints-max-width exwm--normal-hints-max-height' are +unset." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (and (not force) + (or exwm--normal-hints-x exwm--normal-hints-y + exwm--normal-hints-width exwm--normal-hints-height + exwm--normal-hints-min-width exwm--normal-hints-min-height + exwm--normal-hints-max-width exwm--normal-hints-max-height + ;; FIXME: other fields + )) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:icccm:get-WM_NORMAL_HINTS + :window id)))) + (when (and reply (slot-value reply 'flags)) ;nil when destroyed + (with-slots (flags x y width height min-width min-height max-width + max-height base-width base-height ;; win-gravity + ) + reply + (unless (= 0 (logand flags xcb:icccm:WM_SIZE_HINTS:USPosition)) + (setq exwm--normal-hints-x x exwm--normal-hints-y y)) + (unless (= 0 (logand flags xcb:icccm:WM_SIZE_HINTS:USSize)) + (setq exwm--normal-hints-width width + exwm--normal-hints-height height)) + (unless (= 0 (logand flags xcb:icccm:WM_SIZE_HINTS:PMinSize)) + (setq exwm--normal-hints-min-width min-width + exwm--normal-hints-min-height min-height)) + (unless (= 0 (logand flags xcb:icccm:WM_SIZE_HINTS:PMaxSize)) + (setq exwm--normal-hints-max-width max-width + exwm--normal-hints-max-height max-height)) + (unless (or exwm--normal-hints-min-width + (= 0 (logand flags xcb:icccm:WM_SIZE_HINTS:PBaseSize))) + (setq exwm--normal-hints-min-width base-width + exwm--normal-hints-min-height base-height)) + ;; (unless (= 0 (logand flags xcb:icccm:WM_SIZE_HINTS:PWinGravity)) + ;; (setq exwm--normal-hints-win-gravity win-gravity)) + (setq exwm--fixed-size + (and exwm--normal-hints-min-width + exwm--normal-hints-min-height + exwm--normal-hints-max-width + exwm--normal-hints-max-height + (/= 0 exwm--normal-hints-min-width) + (/= 0 exwm--normal-hints-min-height) + (= exwm--normal-hints-min-width + exwm--normal-hints-max-width) + (= exwm--normal-hints-min-height + exwm--normal-hints-max-height))))))))) + +(defun exwm--update-hints (id &optional force) + "Update hints from WM_HINTS. +Argument ID contains the X window of the `exwm-mode' buffer. + +When FORCE is nil the update only takes place if both of +`exwm--hints-input' and `exwm--hints-urgency' are unset." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (and (not force) exwm--hints-input exwm--hints-urgency) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:icccm:get-WM_HINTS :window id)))) + (when (and reply (slot-value reply 'flags)) ;nil when destroyed + (with-slots (flags input initial-state) reply + (when flags + (unless (= 0 (logand flags xcb:icccm:WM_HINTS:InputHint)) + (setq exwm--hints-input (when input (= 1 input)))) + (unless (= 0 (logand flags xcb:icccm:WM_HINTS:StateHint)) + (setq exwm-state initial-state)) + (unless (= 0 (logand flags xcb:icccm:WM_HINTS:UrgencyHint)) + (setq exwm--hints-urgency t)))) + (when (and exwm--hints-urgency + (not (eq exwm--frame exwm-workspace--current))) + (unless (frame-parameter exwm--frame 'exwm-urgency) + (set-frame-parameter exwm--frame 'exwm-urgency t) + (setq exwm-workspace--switch-history-outdated t)))))))) + +(defun exwm--update-protocols (id &optional force) + "Update `exwm--protocols' from WM_PROTOCOLS. +Argument ID contains the X window of the `exwm-mode' buffer. + +When FORCE is nil the update only takes place if `exwm--protocols' +is unset." + (exwm--log "#x%x" id) + (with-current-buffer (exwm--id->buffer id) + (unless (and exwm--protocols (not force)) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:icccm:get-WM_PROTOCOLS + :window id)))) + (when reply ;nil when destroyed + (setq exwm--protocols (append (slot-value reply 'value) nil))))))) + +(defun exwm--update-struts-legacy (id) + "Update struts of X window ID from _NET_WM_STRUT." + (exwm--log "#x%x" id) + (let ((pair (assq id exwm-workspace--id-struts-alist)) + reply struts) + (unless (and pair (< 4 (length (cdr pair)))) + (setq reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:ewmh:get-_NET_WM_STRUT + :window id))) + (when reply + (setq struts (slot-value reply 'value)) + (if pair + (setcdr pair struts) + (push (cons id struts) exwm-workspace--id-struts-alist)) + (exwm-workspace--update-struts)) + ;; Update workareas. + (exwm-workspace--update-workareas) + ;; Update workspaces. + (dolist (f exwm-workspace--list) + (exwm-workspace--set-fullscreen f))))) + +(defun exwm--update-struts-partial (id) + "Update struts of X window ID from _NET_WM_STRUT_PARTIAL." + (exwm--log "#x%x" id) + (let ((reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:ewmh:get-_NET_WM_STRUT_PARTIAL + :window id))) + struts pair) + (when reply + (setq struts (slot-value reply 'value) + pair (assq id exwm-workspace--id-struts-alist)) + (if pair + (setcdr pair struts) + (push (cons id struts) exwm-workspace--id-struts-alist)) + (exwm-workspace--update-struts)) + ;; Update workareas. + (exwm-workspace--update-workareas) + ;; Update workspaces. + (dolist (f exwm-workspace--list) + (exwm-workspace--set-fullscreen f)))) + +(defun exwm--update-struts (id) + "Update struts of X window ID from _NET_WM_STRUT_PARTIAL or _NET_WM_STRUT." + (exwm--log "#x%x" id) + (exwm--update-struts-partial id) + (exwm--update-struts-legacy id)) + +(defun exwm--on-PropertyNotify (data _synthetic) + "Handle PropertyNotify event. +DATA contains unmarshalled PropertyNotify event data." + (let ((obj (make-instance 'xcb:PropertyNotify)) + atom id buffer) + (xcb:unmarshal obj data) + (setq id (slot-value obj 'window) + atom (slot-value obj 'atom)) + (exwm--log "atom=%s(%s)" (x-get-atom-name atom exwm-workspace--current) atom) + (setq buffer (exwm--id->buffer id)) + (if (not (buffer-live-p buffer)) + ;; Properties of unmanaged X windows. + (cond ((= atom xcb:Atom:_NET_WM_STRUT) + (exwm--update-struts-legacy id)) + ((= atom xcb:Atom:_NET_WM_STRUT_PARTIAL) + (exwm--update-struts-partial id))) + (with-current-buffer buffer + (cond ((= atom xcb:Atom:_NET_WM_WINDOW_TYPE) + (exwm--update-window-type id t)) + ((= atom xcb:Atom:WM_CLASS) + (exwm--update-class id t)) + ((= atom xcb:Atom:_NET_WM_NAME) + (exwm--update-utf8-title id t)) + ((= atom xcb:Atom:WM_NAME) + (exwm--update-ctext-title id t)) + ((= atom xcb:Atom:WM_TRANSIENT_FOR) + (exwm--update-transient-for id t)) + ((= atom xcb:Atom:WM_NORMAL_HINTS) + (exwm--update-normal-hints id t)) + ((= atom xcb:Atom:WM_HINTS) + (exwm--update-hints id t)) + ((= atom xcb:Atom:WM_PROTOCOLS) + (exwm--update-protocols id t)) + ((= atom xcb:Atom:_NET_WM_USER_TIME)) ;ignored + (t + (exwm--log "Unhandled: %s(%d)" + (x-get-atom-name atom exwm-workspace--current) + atom))))))) + +(defun exwm--on-ClientMessage (raw-data _synthetic) + "Handle ClientMessage event. +RAW-DATA contains unmarshalled ClientMessage event data." + (let ((obj (make-instance 'xcb:ClientMessage)) + type id data) + (xcb:unmarshal obj raw-data) + (setq type (slot-value obj 'type) + id (slot-value obj 'window) + data (slot-value (slot-value obj 'data) 'data32)) + (exwm--log "atom=%s(%s) id=#x%x data=%s" (x-get-atom-name type exwm-workspace--current) + type (or id 0) data) + (cond + ;; _NET_NUMBER_OF_DESKTOPS. + ((= type xcb:Atom:_NET_NUMBER_OF_DESKTOPS) + (let ((current (exwm-workspace--count)) + (requested (elt data 0))) + ;; Only allow increasing/decreasing the workspace number by 1. + (cond + ((< current requested) + (make-frame)) + ((and (> current requested) + (> current 1)) + (let ((frame (car (last exwm-workspace--list)))) + (delete-frame frame)))))) + ;; _NET_CURRENT_DESKTOP. + ((= type xcb:Atom:_NET_CURRENT_DESKTOP) + (exwm-workspace-switch (elt data 0))) + ;; _NET_ACTIVE_WINDOW. + ((= type xcb:Atom:_NET_ACTIVE_WINDOW) + (let ((buffer (exwm--id->buffer id)) + iconic window) + (if (buffer-live-p buffer) + ;; Either an `exwm-mode' buffer (an X window) or a floating frame. + (with-current-buffer buffer + (when (eq exwm--frame exwm-workspace--current) + (if exwm--floating-frame + (select-frame exwm--floating-frame) + (setq iconic (exwm-layout--iconic-state-p)) + (when iconic + ;; State change: iconic => normal. + (set-window-buffer (frame-selected-window exwm--frame) + (current-buffer))) + ;; Focus transfer. + (setq window (get-buffer-window nil t)) + (when (or iconic + (not (eq window (selected-window)))) + (select-window window))))) + ;; A workspace. + (dolist (f exwm-workspace--list) + (when (eq id (frame-parameter f 'exwm-outer-id)) + (x-focus-frame f t)))))) + ;; _NET_CLOSE_WINDOW. + ((= type xcb:Atom:_NET_CLOSE_WINDOW) + (let ((buffer (exwm--id->buffer id))) + (when (buffer-live-p buffer) + (exwm--defer 0 #'kill-buffer buffer)))) + ;; _NET_WM_MOVERESIZE + ((= type xcb:Atom:_NET_WM_MOVERESIZE) + (let ((direction (elt data 2)) + (buffer (exwm--id->buffer id))) + (unless (and buffer + (not (buffer-local-value 'exwm--floating-frame buffer))) + (cond ((= direction + xcb:ewmh:_NET_WM_MOVERESIZE_SIZE_KEYBOARD) + ;; FIXME + ) + ((= direction + xcb:ewmh:_NET_WM_MOVERESIZE_MOVE_KEYBOARD) + ;; FIXME + ) + ((= direction xcb:ewmh:_NET_WM_MOVERESIZE_CANCEL) + (exwm-floating--stop-moveresize)) + ;; In case it's a workspace frame. + ((and (not buffer) + (catch 'break + (dolist (f exwm-workspace--list) + (when (or (eq id (frame-parameter f 'exwm-outer-id)) + (eq id (frame-parameter f 'exwm-id))) + (throw 'break t))) + nil))) + (t + ;; In case it's a floating frame, + ;; move the corresponding X window instead. + (unless buffer + (catch 'break + (dolist (pair exwm--id-buffer-alist) + (with-current-buffer (cdr pair) + (when + (and exwm--floating-frame + (or (eq id + (frame-parameter exwm--floating-frame + 'exwm-outer-id)) + (eq id + (frame-parameter exwm--floating-frame + 'exwm-id)))) + (setq id exwm--id) + (throw 'break nil)))))) + ;; Start to move it. + (exwm-floating--start-moveresize id direction)))))) + ;; _NET_REQUEST_FRAME_EXTENTS + ((= type xcb:Atom:_NET_REQUEST_FRAME_EXTENTS) + (let ((buffer (exwm--id->buffer id)) + top btm) + (if (or (not buffer) + (not (buffer-local-value 'exwm--floating-frame buffer))) + (setq top 0 + btm 0) + (setq top (window-header-line-height) + btm (window-mode-line-height))) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_FRAME_EXTENTS + :window id + :left 0 + :right 0 + :top top + :bottom btm))) + (xcb:flush exwm--connection)) + ;; _NET_WM_DESKTOP. + ((= type xcb:Atom:_NET_WM_DESKTOP) + (let ((buffer (exwm--id->buffer id))) + (when (buffer-live-p buffer) + (exwm-workspace-move-window (elt data 0) id)))) + ;; _NET_WM_STATE + ((= type xcb:Atom:_NET_WM_STATE) + (let ((action (elt data 0)) + (props (list (elt data 1) (elt data 2))) + (buffer (exwm--id->buffer id)) + props-new) + ;; only support _NET_WM_STATE_FULLSCREEN / _NET_WM_STATE_ADD for frames + (when (and (not buffer) + (memq xcb:Atom:_NET_WM_STATE_FULLSCREEN props) + (= action xcb:ewmh:_NET_WM_STATE_ADD)) + (xcb:+request + exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_STATE + :window id + :data (vector xcb:Atom:_NET_WM_STATE_FULLSCREEN))) + (xcb:flush exwm--connection)) + (when buffer ;ensure it's managed + (with-current-buffer buffer + ;; _NET_WM_STATE_FULLSCREEN + (when (or (memq xcb:Atom:_NET_WM_STATE_FULLSCREEN props) + (memq xcb:Atom:_NET_WM_STATE_ABOVE props)) + (cond ((= action xcb:ewmh:_NET_WM_STATE_ADD) + (unless (exwm-layout--fullscreen-p) + (exwm-layout-set-fullscreen id)) + (push xcb:Atom:_NET_WM_STATE_FULLSCREEN props-new)) + ((= action xcb:ewmh:_NET_WM_STATE_REMOVE) + (when (exwm-layout--fullscreen-p) + (exwm-layout-unset-fullscreen id))) + ((= action xcb:ewmh:_NET_WM_STATE_TOGGLE) + (if (exwm-layout--fullscreen-p) + (exwm-layout-unset-fullscreen id) + (exwm-layout-set-fullscreen id) + (push xcb:Atom:_NET_WM_STATE_FULLSCREEN props-new))))) + ;; _NET_WM_STATE_DEMANDS_ATTENTION + ;; FIXME: check (may require other properties set) + (when (memq xcb:Atom:_NET_WM_STATE_DEMANDS_ATTENTION props) + (when (= action xcb:ewmh:_NET_WM_STATE_ADD) + (unless (eq exwm--frame exwm-workspace--current) + (set-frame-parameter exwm--frame 'exwm-urgency t) + (setq exwm-workspace--switch-history-outdated t))) + ;; xcb:ewmh:_NET_WM_STATE_REMOVE? + ;; xcb:ewmh:_NET_WM_STATE_TOGGLE? + ) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_STATE + :window id :data (vconcat props-new))) + (xcb:flush exwm--connection))))) + ((= type xcb:Atom:WM_PROTOCOLS) + (let ((type (elt data 0))) + (cond ((= type xcb:Atom:_NET_WM_PING) + (setq exwm-manage--ping-lock nil)) + (t (exwm--log "Unhandled WM_PROTOCOLS of type: %d" type))))) + ((= type xcb:Atom:WM_CHANGE_STATE) + (let ((buffer (exwm--id->buffer id))) + (when (and (buffer-live-p buffer) + (= (elt data 0) xcb:icccm:WM_STATE:IconicState)) + (with-current-buffer buffer + (if exwm--floating-frame + (call-interactively #'exwm-floating-hide) + (bury-buffer)))))) + (t + (exwm--log "Unhandled: %s(%d)" + (x-get-atom-name type exwm-workspace--current) type))))) + +(defun exwm--on-SelectionClear (data _synthetic) + "Handle SelectionClear events. +DATA contains unmarshalled SelectionClear event data." + (exwm--log) + (let ((obj (make-instance 'xcb:SelectionClear)) + owner selection) + (xcb:unmarshal obj data) + (setq owner (slot-value obj 'owner) + selection (slot-value obj 'selection)) + (when (and (eq owner exwm--wmsn-window) + (eq selection xcb:Atom:WM_S0)) + (exwm-exit)))) + +(defun exwm--on-delete-terminal (terminal) + "Handle terminal being deleted without Emacs being killed. +This function is Hooked to `delete-terminal-functions'. + +TERMINAL is the terminal being (or that has been) deleted. + +This may happen when invoking `save-buffers-kill-terminal' within an emacsclient +session." + (when (eq terminal exwm--terminal) + (exwm-exit))) + +(defun exwm--init-icccm-ewmh () + "Initialize ICCCM/EWMH support." + (exwm--log) + ;; Handle PropertyNotify event + (xcb:+event exwm--connection 'xcb:PropertyNotify #'exwm--on-PropertyNotify) + ;; Handle relevant client messages + (xcb:+event exwm--connection 'xcb:ClientMessage #'exwm--on-ClientMessage) + ;; Handle SelectionClear + (xcb:+event exwm--connection 'xcb:SelectionClear #'exwm--on-SelectionClear) + ;; Set _NET_SUPPORTED + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_SUPPORTED + :window exwm--root + :data (vector + ;; Root windows properties. + xcb:Atom:_NET_SUPPORTED + xcb:Atom:_NET_CLIENT_LIST + xcb:Atom:_NET_CLIENT_LIST_STACKING + xcb:Atom:_NET_NUMBER_OF_DESKTOPS + xcb:Atom:_NET_DESKTOP_GEOMETRY + xcb:Atom:_NET_DESKTOP_VIEWPORT + xcb:Atom:_NET_CURRENT_DESKTOP + ;; xcb:Atom:_NET_DESKTOP_NAMES + xcb:Atom:_NET_ACTIVE_WINDOW + ;; xcb:Atom:_NET_WORKAREA + xcb:Atom:_NET_SUPPORTING_WM_CHECK + ;; xcb:Atom:_NET_VIRTUAL_ROOTS + ;; xcb:Atom:_NET_DESKTOP_LAYOUT + ;; xcb:Atom:_NET_SHOWING_DESKTOP + + ;; Other root window messages. + xcb:Atom:_NET_CLOSE_WINDOW + ;; xcb:Atom:_NET_MOVERESIZE_WINDOW + xcb:Atom:_NET_WM_MOVERESIZE + ;; xcb:Atom:_NET_RESTACK_WINDOW + xcb:Atom:_NET_REQUEST_FRAME_EXTENTS + + ;; Application window properties. + xcb:Atom:_NET_WM_NAME + ;; xcb:Atom:_NET_WM_VISIBLE_NAME + ;; xcb:Atom:_NET_WM_ICON_NAME + ;; xcb:Atom:_NET_WM_VISIBLE_ICON_NAME + xcb:Atom:_NET_WM_DESKTOP + ;; + xcb:Atom:_NET_WM_WINDOW_TYPE + ;; xcb:Atom:_NET_WM_WINDOW_TYPE_DESKTOP + xcb:Atom:_NET_WM_WINDOW_TYPE_DOCK + xcb:Atom:_NET_WM_WINDOW_TYPE_TOOLBAR + xcb:Atom:_NET_WM_WINDOW_TYPE_MENU + xcb:Atom:_NET_WM_WINDOW_TYPE_UTILITY + xcb:Atom:_NET_WM_WINDOW_TYPE_SPLASH + xcb:Atom:_NET_WM_WINDOW_TYPE_DIALOG + xcb:Atom:_NET_WM_WINDOW_TYPE_DROPDOWN_MENU + xcb:Atom:_NET_WM_WINDOW_TYPE_POPUP_MENU + xcb:Atom:_NET_WM_WINDOW_TYPE_TOOLTIP + xcb:Atom:_NET_WM_WINDOW_TYPE_NOTIFICATION + xcb:Atom:_NET_WM_WINDOW_TYPE_COMBO + xcb:Atom:_NET_WM_WINDOW_TYPE_DND + xcb:Atom:_NET_WM_WINDOW_TYPE_NORMAL + ;; + xcb:Atom:_NET_WM_STATE + ;; xcb:Atom:_NET_WM_STATE_MODAL + ;; xcb:Atom:_NET_WM_STATE_STICKY + ;; xcb:Atom:_NET_WM_STATE_MAXIMIZED_VERT + ;; xcb:Atom:_NET_WM_STATE_MAXIMIZED_HORZ + ;; xcb:Atom:_NET_WM_STATE_SHADED + ;; xcb:Atom:_NET_WM_STATE_SKIP_TASKBAR + ;; xcb:Atom:_NET_WM_STATE_SKIP_PAGER + xcb:Atom:_NET_WM_STATE_HIDDEN + xcb:Atom:_NET_WM_STATE_FULLSCREEN + ;; xcb:Atom:_NET_WM_STATE_ABOVE + ;; xcb:Atom:_NET_WM_STATE_BELOW + xcb:Atom:_NET_WM_STATE_DEMANDS_ATTENTION + ;; xcb:Atom:_NET_WM_STATE_FOCUSED + ;; + xcb:Atom:_NET_WM_ALLOWED_ACTIONS + xcb:Atom:_NET_WM_ACTION_MOVE + xcb:Atom:_NET_WM_ACTION_RESIZE + xcb:Atom:_NET_WM_ACTION_MINIMIZE + ;; xcb:Atom:_NET_WM_ACTION_SHADE + ;; xcb:Atom:_NET_WM_ACTION_STICK + ;; xcb:Atom:_NET_WM_ACTION_MAXIMIZE_HORZ + ;; xcb:Atom:_NET_WM_ACTION_MAXIMIZE_VERT + xcb:Atom:_NET_WM_ACTION_FULLSCREEN + xcb:Atom:_NET_WM_ACTION_CHANGE_DESKTOP + xcb:Atom:_NET_WM_ACTION_CLOSE + ;; xcb:Atom:_NET_WM_ACTION_ABOVE + ;; xcb:Atom:_NET_WM_ACTION_BELOW + ;; + xcb:Atom:_NET_WM_STRUT + xcb:Atom:_NET_WM_STRUT_PARTIAL + ;; xcb:Atom:_NET_WM_ICON_GEOMETRY + ;; xcb:Atom:_NET_WM_ICON + xcb:Atom:_NET_WM_PID + ;; xcb:Atom:_NET_WM_HANDLED_ICONS + ;; xcb:Atom:_NET_WM_USER_TIME + ;; xcb:Atom:_NET_WM_USER_TIME_WINDOW + xcb:Atom:_NET_FRAME_EXTENTS + ;; xcb:Atom:_NET_WM_OPAQUE_REGION + ;; xcb:Atom:_NET_WM_BYPASS_COMPOSITOR + + ;; Window manager protocols. + xcb:Atom:_NET_WM_PING + ;; xcb:Atom:_NET_WM_SYNC_REQUEST + ;; xcb:Atom:_NET_WM_FULLSCREEN_MONITORS + + ;; Other properties. + xcb:Atom:_NET_WM_FULL_PLACEMENT))) + ;; Create a child window for setting _NET_SUPPORTING_WM_CHECK + (let ((new-id (xcb:generate-id exwm--connection))) + (setq exwm--guide-window new-id) + (xcb:+request exwm--connection + (make-instance 'xcb:CreateWindow + :depth 0 + :wid new-id + :parent exwm--root + :x -1 + :y -1 + :width 1 + :height 1 + :border-width 0 + :class xcb:WindowClass:InputOnly + :visual 0 + :value-mask xcb:CW:OverrideRedirect + :override-redirect 1)) + ;; Set _NET_WM_NAME. Must be set to the name of the window manager, as + ;; required by wm-spec. + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window new-id :data "EXWM")) + (dolist (i (list exwm--root new-id)) + ;; Set _NET_SUPPORTING_WM_CHECK + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_SUPPORTING_WM_CHECK + :window i :data new-id)))) + ;; Set _NET_DESKTOP_VIEWPORT (we don't support large desktop). + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_DESKTOP_VIEWPORT + :window exwm--root + :data [0 0])) + (xcb:flush exwm--connection)) + +(defun exwm--wmsn-acquire (replace) + "Acquire the WM_Sn selection. + +REPLACE specifies what to do in case there already is a window +manager. If t, replace it, if nil, abort and ask the user if `ask'." + (exwm--log "%s" replace) + (with-slots (owner) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetSelectionOwner + :selection xcb:Atom:WM_S0)) + (when (/= owner xcb:Window:None) + (when (eq replace 'ask) + (setq replace (yes-or-no-p "Replace existing window manager? "))) + (when (not replace) + (user-error "Other window manager detected"))) + (let ((new-owner (xcb:generate-id exwm--connection))) + (xcb:+request exwm--connection + (make-instance 'xcb:CreateWindow + :depth 0 + :wid new-owner + :parent exwm--root + :x -1 + :y -1 + :width 1 + :height 1 + :border-width 0 + :class xcb:WindowClass:CopyFromParent + :visual 0 + :value-mask 0 + :override-redirect 0)) + (xcb:+request exwm--connection + (make-instance 'xcb:ewmh:set-_NET_WM_NAME + :window new-owner :data "EXWM: exwm--wmsn-window")) + (xcb:+request-checked+request-check exwm--connection + (make-instance 'xcb:SetSelectionOwner + :selection xcb:Atom:WM_S0 + :owner new-owner + :time xcb:Time:CurrentTime)) + (with-slots (owner) + (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetSelectionOwner + :selection xcb:Atom:WM_S0)) + (unless (eq owner new-owner) + (error "Could not acquire ownership of WM selection"))) + ;; Wait for the other window manager to terminate. + (when (/= owner xcb:Window:None) + (let (reply) + (cl-dotimes (i exwm--wmsn-acquire-timeout) + (setq reply (xcb:+request-unchecked+reply exwm--connection + (make-instance 'xcb:GetGeometry :drawable owner))) + (when (not reply) + (cl-return)) + (message "Waiting for other window manager to quit... %ds" i) + (sleep-for 1)) + (when reply + (error "Other window manager did not release selection in time")))) + ;; announce + (let* ((cmd (make-instance 'xcb:ClientMessageData + :data32 (vector xcb:Time:CurrentTime + xcb:Atom:WM_S0 + new-owner + 0 + 0))) + (cm (make-instance 'xcb:ClientMessage + :window exwm--root + :format 32 + :type xcb:Atom:MANAGER + :data cmd)) + (se (make-instance 'xcb:SendEvent + :propagate 0 + :destination exwm--root + :event-mask xcb:EventMask:NoEvent + :event (xcb:marshal cm exwm--connection)))) + (xcb:+request exwm--connection se)) + (setq exwm--wmsn-window new-owner)))) + +;;;###autoload +(cl-defun exwm-init (&optional frame) + "Initialize EXWM. +FRAME, if given, indicates the X display EXWM should manage." + (interactive) + (exwm--log "%s" frame) + (if frame + ;; The frame might not be selected if it's created by emacslicnet. + (select-frame-set-input-focus frame) + (setq frame (selected-frame))) + (when (not (eq 'x (framep frame))) + (message "[EXWM] Not running under X environment") + (cl-return-from exwm-init)) + (when exwm--connection + (exwm--log "EXWM already running") + (cl-return-from exwm-init)) + (condition-case err + (progn + (exwm-enable 'undo) ;never initialize again + (setq exwm--terminal (frame-terminal frame)) + (setq exwm--connection (xcb:connect)) + (set-process-query-on-exit-flag (slot-value exwm--connection 'process) + nil) ;prevent query message on exit + (setq exwm--root + (slot-value (car (slot-value + (xcb:get-setup exwm--connection) 'roots)) + 'root)) + ;; Initialize ICCCM/EWMH support + (xcb:icccm:init exwm--connection t) + (xcb:ewmh:init exwm--connection t) + ;; Try to register window manager selection. + (exwm--wmsn-acquire exwm-replace) + (when (xcb:+request-checked+request-check exwm--connection + (make-instance 'xcb:ChangeWindowAttributes + :window exwm--root + :value-mask xcb:CW:EventMask + :event-mask + xcb:EventMask:SubstructureRedirect)) + (error "Other window manager is running")) + ;; Disable some features not working well with EXWM + (setq use-dialog-box nil + confirm-kill-emacs #'exwm--confirm-kill-emacs) + (advice-add 'save-buffers-kill-terminal + :before-while #'exwm--confirm-kill-terminal) + ;; Clean up if the terminal is deleted. + (add-hook 'delete-terminal-functions 'exwm--on-delete-terminal) + (exwm--lock) + (exwm--init-icccm-ewmh) + (exwm-layout--init) + (exwm-floating--init) + (exwm-manage--init) + (exwm-workspace--init) + (exwm-input--init) + (exwm--unlock) + (exwm-workspace--post-init) + (exwm-input--post-init) + (run-hooks 'exwm-init-hook) + ;; Manage existing windows + (exwm-manage--scan)) + (user-error) + ((quit error) + (exwm-exit) + ;; Rethrow error + (warn "[EXWM] EXWM fails to start (%s: %s)" (car err) (cdr err))))) + + +;;;###autoload +(defun exwm-exit () + "Exit EXWM." + (interactive) + (exwm--log) + (run-hooks 'exwm-exit-hook) + (setq confirm-kill-emacs nil) + ;; Exit modules. + (when exwm--connection + (exwm-input--exit) + (exwm-manage--exit) + (exwm-workspace--exit) + (exwm-floating--exit) + (exwm-layout--exit) + (xcb:flush exwm--connection) + (xcb:disconnect exwm--connection)) + (setq exwm--connection nil) + (setq exwm--terminal nil) + (exwm--log "Exited")) + +;;;###autoload +(defun exwm-enable (&optional undo) + "Enable/Disable EXWM." + (exwm--log "%s" undo) + (pcase undo + (`undo ;prevent reinitialization + (remove-hook 'window-setup-hook #'exwm-init) + (remove-hook 'after-make-frame-functions #'exwm-init)) + (`undo-all ;attempt to revert everything + (remove-hook 'window-setup-hook #'exwm-init) + (remove-hook 'after-make-frame-functions #'exwm-init) + (remove-hook 'kill-emacs-hook #'exwm--server-stop) + (dolist (i exwm-blocking-subrs) + (advice-remove i #'exwm--server-eval-at))) + (_ ;enable EXWM + (setq frame-resize-pixelwise t ;mandatory; before init + window-resize-pixelwise t) + ;; Ignore unrecognized command line arguments. This can be helpful + ;; when EXWM is launched by some session manager. + (push #'vector command-line-functions) + ;; In case EXWM is to be started from a graphical Emacs instance. + (add-hook 'window-setup-hook #'exwm-init t) + ;; In case EXWM is to be started with emacsclient. + (add-hook 'after-make-frame-functions #'exwm-init t) + ;; Manage the subordinate Emacs server. + (add-hook 'kill-emacs-hook #'exwm--server-stop) + (dolist (i exwm-blocking-subrs) + (advice-add i :around #'exwm--server-eval-at))))) + +(defun exwm--server-stop () + "Stop the subordinate Emacs server." + (exwm--log) + (when exwm--server-process + (when (process-live-p exwm--server-process) + (cl-loop + initially (signal-process exwm--server-process 'TERM) + while (process-live-p exwm--server-process) + repeat (* 10 exwm--server-timeout) + do (sit-for 0.1))) + (delete-process exwm--server-process) + (setq exwm--server-process nil))) + +(defun exwm--server-eval-at (function &rest args) + "Wrapper of `server-eval-at' used to advice subrs. +FUNCTION is the function to be evaluated, ARGS are the arguments." + ;; Start the subordinate Emacs server if it's not alive + (exwm--log "%s %s" function args) + (unless (server-running-p exwm--server-name) + (when exwm--server-process (delete-process exwm--server-process)) + (setq exwm--server-process + (start-process exwm--server-name + nil + (car command-line-args) ;The executable file + "-d" (frame-parameter nil 'display) + "-Q" + (concat "--fg-daemon=" exwm--server-name) + "--eval" + ;; Create an invisible frame + "(make-frame '((window-system . x) (visibility)))")) + (while (not (server-running-p exwm--server-name)) + (sit-for 0.001))) + (server-eval-at + exwm--server-name + `(progn (select-frame (car (frame-list))) + (let ((result ,(nconc (list (make-symbol (subr-name function))) + args))) + (pcase (type-of result) + ;; Return the name of a buffer + (`buffer (buffer-name result)) + ;; We blindly convert all font objects to their XLFD names. This + ;; might cause problems of course, but it still has a chance to + ;; work (whereas directly passing font objects would merely + ;; raise errors). + ((or `font-entity `font-object `font-spec) + (font-xlfd-name result)) + ;; Passing following types makes little sense + ((or `compiled-function `finalizer `frame `hash-table `marker + `overlay `process `window `window-configuration)) + ;; Passing the name of a subr + (`subr (make-symbol (subr-name result))) + ;; For other types, return the value as-is. + (t result)))))) + +(defun exwm--confirm-kill-terminal (&optional _) + "Confirm before killing terminal." + ;; This is invoked instead of `save-buffers-kill-emacs' (C-x C-c) on client + ;; frames. + (if (exwm--terminal-p) + (exwm--confirm-kill-emacs "Kill terminal?") + t)) + +(defun exwm--confirm-kill-emacs (prompt &optional force) + "Confirm before exiting Emacs. +PROMPT a reason to present to the user. +If FORCE is nil, ask the user for confirmation. +If FORCE is the symbol `no-check', ask if there are unsaved buffers. +If FORCE is any other non-nil value, force killing of Emacs." + (exwm--log) + (when (cond + ((and force (not (eq force 'no-check))) + ;; Force killing Emacs. + t) + ((or (eq force 'no-check) (not exwm--id-buffer-alist)) + ;; Check if there's any unsaved file. + (pcase (catch 'break + (let ((kill-emacs-query-functions + (append kill-emacs-query-functions + (list (lambda () + (throw 'break 'break)))))) + (save-buffers-kill-emacs))) + (`break (y-or-n-p prompt)) + (x x))) + (t + (yes-or-no-p (format "[EXWM] %d X window(s) will be destroyed. %s" + (length exwm--id-buffer-alist) prompt)))) + ;; Run `kill-emacs-hook' (`server-force-stop' excluded) before Emacs + ;; frames are unmapped so that errors (if any) can be visible. + (if (memq #'server-force-stop kill-emacs-hook) + (progn + (setq kill-emacs-hook (delq #'server-force-stop kill-emacs-hook)) + (run-hooks 'kill-emacs-hook) + (setq kill-emacs-hook (list #'server-force-stop))) + (run-hooks 'kill-emacs-hook) + (setq kill-emacs-hook nil)) + ;; Exit each module, destroying all resources created by this connection. + (exwm-exit) + ;; Set the return value. + t)) + + + +(provide 'exwm) + +;;; exwm.el ends here diff --git a/third_party/exwm/xinitrc b/third_party/exwm/xinitrc new file mode 100644 index 0000000000..591e419914 --- /dev/null +++ b/third_party/exwm/xinitrc @@ -0,0 +1,20 @@ +# Disable access control for the current user. +xhost +SI:localuser:$USER + +# Make Java applications aware this is a non-reparenting window manager. +export _JAVA_AWT_WM_NONREPARENTING=1 + +# Set default cursor. +xsetroot -cursor_name left_ptr + +# Set keyboard repeat rate. +xset r rate 200 60 + +# Uncomment the following block to use the exwm-xim module. +#export XMODIFIERS=@im=exwm-xim +#export GTK_IM_MODULE=xim +#export QT_IM_MODULE=xim +#export CLUTTER_IM_MODULE=xim + +# Finally start Emacs +exec emacs diff --git a/third_party/geesefs/default.nix b/third_party/geesefs/default.nix new file mode 100644 index 0000000000..7e140cfb81 --- /dev/null +++ b/third_party/geesefs/default.nix @@ -0,0 +1,25 @@ +# Finally, a good FUSE FS implementation over S3. +# https://github.com/yandex-cloud/geesefs + +{ pkgs, ... }: + +pkgs.buildGoModule rec { + pname = "geesefs"; + version = "0.38.3"; + + src = pkgs.fetchFromGitHub { + owner = "yandex-cloud"; + repo = "geesefs"; + rev = "v${version}"; + sha256 = "0kf0368hnards619azz8xw7cp7fm806v0aszmgq24qs9ax45dv6m"; + }; + + subPackages = [ "." ]; + buildInputs = [ pkgs.fuse ]; + vendorSha256 = "sha256-5QPx6mNJLbhqTF6EF/ZK8CVOnLcM0wpbCwDyd9mWhAM="; + + meta = with pkgs.lib; { + license = licenses.asl20; + maintainers = [ maintainers.tazjin ]; + }; +} diff --git a/third_party/gerrit/0001-Syntax-highlight-nix.patch b/third_party/gerrit/0001-Syntax-highlight-nix.patch new file mode 100644 index 0000000000..bdc3fd3b55 --- /dev/null +++ b/third_party/gerrit/0001-Syntax-highlight-nix.patch @@ -0,0 +1,37 @@ +From 084e4f92fb58f7cd85303ba602fb3c40133c8fcc Mon Sep 17 00:00:00 2001 +From: Luke Granger-Brown <git@lukegb.com> +Date: Thu, 2 Jul 2020 23:02:32 +0100 +Subject: [PATCH 1/3] Syntax highlight nix + +--- + .../app/embed/diff/gr-syntax-layer/gr-syntax-layer-worker.ts | 1 + + resources/com/google/gerrit/server/mime/mime-types.properties | 1 + + 2 files changed, 2 insertions(+) + +diff --git a/polygerrit-ui/app/embed/diff/gr-syntax-layer/gr-syntax-layer-worker.ts b/polygerrit-ui/app/embed/diff/gr-syntax-layer/gr-syntax-layer-worker.ts +index a9f88bdd81..385249f280 100644 +--- a/polygerrit-ui/app/embed/diff/gr-syntax-layer/gr-syntax-layer-worker.ts ++++ b/polygerrit-ui/app/embed/diff/gr-syntax-layer/gr-syntax-layer-worker.ts +@@ -93,6 +93,7 @@ const LANGUAGE_MAP = new Map<string, string>([ + ['text/x-vhdl', 'vhdl'], + ['text/x-yaml', 'yaml'], + ['text/vbscript', 'vbscript'], ++ ['text/x-nix', 'nix'], + ]); + + const CLASS_PREFIX = 'gr-diff gr-syntax gr-syntax-'; +diff --git a/resources/com/google/gerrit/server/mime/mime-types.properties b/resources/com/google/gerrit/server/mime/mime-types.properties +index 2f9561ba2e..739818ec05 100644 +--- a/resources/com/google/gerrit/server/mime/mime-types.properties ++++ b/resources/com/google/gerrit/server/mime/mime-types.properties +@@ -149,6 +149,7 @@ mscin = text/x-mscgen + msgenny = text/x-msgenny + nb = text/x-mathematica + nginx.conf = text/x-nginx-conf ++nix = text/x-nix + nsh = text/x-nsis + nsi = text/x-nsis + nt = text/n-triples +-- +2.37.3 + diff --git a/third_party/gerrit/0002-Syntax-highlight-rules.pl.patch b/third_party/gerrit/0002-Syntax-highlight-rules.pl.patch new file mode 100644 index 0000000000..4b91e2c354 --- /dev/null +++ b/third_party/gerrit/0002-Syntax-highlight-rules.pl.patch @@ -0,0 +1,37 @@ +From aedf8ac8fa5113843bcd83ff85e2d9f3bffdb16c Mon Sep 17 00:00:00 2001 +From: Luke Granger-Brown <git@lukegb.com> +Date: Thu, 2 Jul 2020 23:02:43 +0100 +Subject: [PATCH 2/3] Syntax highlight rules.pl + +--- + .../app/embed/diff/gr-syntax-layer/gr-syntax-layer-worker.ts | 1 + + resources/com/google/gerrit/server/mime/mime-types.properties | 1 + + 2 files changed, 2 insertions(+) + +diff --git a/polygerrit-ui/app/embed/diff/gr-syntax-layer/gr-syntax-layer-worker.ts b/polygerrit-ui/app/embed/diff/gr-syntax-layer/gr-syntax-layer-worker.ts +index 385249f280..7cb3068494 100644 +--- a/polygerrit-ui/app/embed/diff/gr-syntax-layer/gr-syntax-layer-worker.ts ++++ b/polygerrit-ui/app/embed/diff/gr-syntax-layer/gr-syntax-layer-worker.ts +@@ -68,6 +68,7 @@ const LANGUAGE_MAP = new Map<string, string>([ + ['text/x-perl', 'perl'], + ['text/x-pgsql', 'pgsql'], // postgresql + ['text/x-php', 'php'], ++ ['text/x-prolog', 'prolog'], + ['text/x-properties', 'properties'], + ['text/x-protobuf', 'protobuf'], + ['text/x-puppet', 'puppet'], +diff --git a/resources/com/google/gerrit/server/mime/mime-types.properties b/resources/com/google/gerrit/server/mime/mime-types.properties +index 739818ec05..58eb727bf9 100644 +--- a/resources/com/google/gerrit/server/mime/mime-types.properties ++++ b/resources/com/google/gerrit/server/mime/mime-types.properties +@@ -200,6 +200,7 @@ rq = application/sparql-query + rs = text/x-rustsrc + rss = application/xml + rst = text/x-rst ++rules.pl = text/x-prolog + README.md = text/x-gfm + s = text/x-gas + sas = text/x-sas +-- +2.37.3 + diff --git a/third_party/gerrit/0003-Add-titles-to-CLs-over-HTTP.patch b/third_party/gerrit/0003-Add-titles-to-CLs-over-HTTP.patch new file mode 100644 index 0000000000..c4edee3a40 --- /dev/null +++ b/third_party/gerrit/0003-Add-titles-to-CLs-over-HTTP.patch @@ -0,0 +1,215 @@ +From f49c50ca9a84ca374b7bd91c171bbea0457f2c7a Mon Sep 17 00:00:00 2001 +From: Luke Granger-Brown <git@lukegb.com> +Date: Thu, 2 Jul 2020 23:03:02 +0100 +Subject: [PATCH 3/3] Add titles to CLs over HTTP + +--- + .../gerrit/httpd/raw/IndexHtmlUtil.java | 13 +++- + .../google/gerrit/httpd/raw/IndexServlet.java | 8 ++- + .../google/gerrit/httpd/raw/StaticModule.java | 5 +- + .../gerrit/httpd/raw/TitleComputer.java | 67 +++++++++++++++++++ + .../gerrit/httpd/raw/PolyGerritIndexHtml.soy | 4 +- + 5 files changed, 89 insertions(+), 8 deletions(-) + create mode 100644 java/com/google/gerrit/httpd/raw/TitleComputer.java + +diff --git a/java/com/google/gerrit/httpd/raw/IndexHtmlUtil.java b/java/com/google/gerrit/httpd/raw/IndexHtmlUtil.java +index 72bfe40c3b..439bd73b44 100644 +--- a/java/com/google/gerrit/httpd/raw/IndexHtmlUtil.java ++++ b/java/com/google/gerrit/httpd/raw/IndexHtmlUtil.java +@@ -41,6 +41,7 @@ import java.util.Collections; + import java.util.HashMap; + import java.util.HashSet; + import java.util.Map; ++import java.util.Optional; + import java.util.Set; + import java.util.function.Function; + +@@ -62,13 +63,14 @@ public class IndexHtmlUtil { + String faviconPath, + Map<String, String[]> urlParameterMap, + Function<String, SanitizedContent> urlInScriptTagOrdainer, +- String requestedURL) ++ String requestedURL, ++ TitleComputer titleComputer) + throws URISyntaxException, RestApiException { + ImmutableMap.Builder<String, Object> data = ImmutableMap.builder(); + data.putAll( + staticTemplateData( + canonicalURL, cdnPath, faviconPath, urlParameterMap, urlInScriptTagOrdainer)) +- .putAll(dynamicTemplateData(gerritApi, requestedURL)); ++ .putAll(dynamicTemplateData(gerritApi, requestedURL, titleComputer)); + Set<String> enabledExperiments = new HashSet<>(); + enabledExperiments.addAll(experimentFeatures.getEnabledExperimentFeatures()); + // Add all experiments enabled through url +@@ -81,7 +83,8 @@ public class IndexHtmlUtil { + + /** Returns dynamic parameters of {@code index.html}. */ + public static ImmutableMap<String, Object> dynamicTemplateData( +- GerritApi gerritApi, String requestedURL) throws RestApiException, URISyntaxException { ++ GerritApi gerritApi, String requestedURL, TitleComputer titleComputer) ++ throws RestApiException, URISyntaxException { + ImmutableMap.Builder<String, Object> data = ImmutableMap.builder(); + Map<String, SanitizedContent> initialData = new HashMap<>(); + Server serverApi = gerritApi.config().server(); +@@ -129,6 +132,10 @@ public class IndexHtmlUtil { + } + + data.put("gerritInitialData", initialData); ++ ++ Optional<String> title = titleComputer.computeTitle(requestedURL); ++ title.ifPresent(s -> data.put("title", s)); ++ + return data.build(); + } + +diff --git a/java/com/google/gerrit/httpd/raw/IndexServlet.java b/java/com/google/gerrit/httpd/raw/IndexServlet.java +index fcb821e5ae..e1464b992b 100644 +--- a/java/com/google/gerrit/httpd/raw/IndexServlet.java ++++ b/java/com/google/gerrit/httpd/raw/IndexServlet.java +@@ -48,13 +48,15 @@ public class IndexServlet extends HttpServlet { + private final ExperimentFeatures experimentFeatures; + private final SoySauce soySauce; + private final Function<String, SanitizedContent> urlOrdainer; ++ private TitleComputer titleComputer; + + IndexServlet( + @Nullable String canonicalUrl, + @Nullable String cdnPath, + @Nullable String faviconPath, + GerritApi gerritApi, +- ExperimentFeatures experimentFeatures) { ++ ExperimentFeatures experimentFeatures, ++ TitleComputer titleComputer) { + this.canonicalUrl = canonicalUrl; + this.cdnPath = cdnPath; + this.faviconPath = faviconPath; +@@ -69,6 +71,7 @@ public class IndexServlet extends HttpServlet { + (s) -> + UnsafeSanitizedContentOrdainer.ordainAsSafe( + s, SanitizedContent.ContentKind.TRUSTED_RESOURCE_URI); ++ this.titleComputer = titleComputer; + } + + @Override +@@ -86,7 +89,8 @@ public class IndexServlet extends HttpServlet { + faviconPath, + parameterMap, + urlOrdainer, +- getRequestUrl(req)); ++ getRequestUrl(req), ++ titleComputer); + renderer = soySauce.renderTemplate("com.google.gerrit.httpd.raw.Index").setData(templateData); + } catch (URISyntaxException | RestApiException e) { + throw new IOException(e); +diff --git a/java/com/google/gerrit/httpd/raw/StaticModule.java b/java/com/google/gerrit/httpd/raw/StaticModule.java +index 15dcf42e0e..9f56bf33ce 100644 +--- a/java/com/google/gerrit/httpd/raw/StaticModule.java ++++ b/java/com/google/gerrit/httpd/raw/StaticModule.java +@@ -241,10 +241,11 @@ public class StaticModule extends ServletModule { + @CanonicalWebUrl @Nullable String canonicalUrl, + @GerritServerConfig Config cfg, + GerritApi gerritApi, +- ExperimentFeatures experimentFeatures) { ++ ExperimentFeatures experimentFeatures, ++ TitleComputer titleComputer) { + String cdnPath = options.devCdn().orElse(cfg.getString("gerrit", null, "cdnPath")); + String faviconPath = cfg.getString("gerrit", null, "faviconPath"); +- return new IndexServlet(canonicalUrl, cdnPath, faviconPath, gerritApi, experimentFeatures); ++ return new IndexServlet(canonicalUrl, cdnPath, faviconPath, gerritApi, experimentFeatures, titleComputer); + } + + @Provides +diff --git a/java/com/google/gerrit/httpd/raw/TitleComputer.java b/java/com/google/gerrit/httpd/raw/TitleComputer.java +new file mode 100644 +index 0000000000..8fd2053ad0 +--- /dev/null ++++ b/java/com/google/gerrit/httpd/raw/TitleComputer.java +@@ -0,0 +1,67 @@ ++package com.google.gerrit.httpd.raw; ++ ++import com.google.common.flogger.FluentLogger; ++import com.google.gerrit.entities.Change; ++import com.google.gerrit.extensions.restapi.ResourceConflictException; ++import com.google.gerrit.extensions.restapi.ResourceNotFoundException; ++import com.google.gerrit.server.change.ChangeResource; ++import com.google.gerrit.server.permissions.PermissionBackendException; ++import com.google.gerrit.server.restapi.change.ChangesCollection; ++import com.google.inject.Inject; ++import com.google.inject.Provider; ++import com.google.inject.Singleton; ++ ++import java.net.MalformedURLException; ++import java.net.URL; ++import java.util.Optional; ++import java.util.regex.Matcher; ++import java.util.regex.Pattern; ++ ++@Singleton ++public class TitleComputer { ++ private static final FluentLogger logger = FluentLogger.forEnclosingClass(); ++ ++ @Inject ++ public TitleComputer(Provider<ChangesCollection> changes) { ++ this.changes = changes; ++ } ++ ++ public Optional<String> computeTitle(String requestedURI) { ++ URL url = null; ++ try { ++ url = new URL(requestedURI); ++ } catch (MalformedURLException e) { ++ logger.atWarning().log("Failed to turn %s into a URL.", requestedURI); ++ return Optional.empty(); ++ } ++ ++ // Try to turn this into a change. ++ Optional<Change.Id> changeId = tryExtractChange(url.getPath()); ++ if (changeId.isPresent()) { ++ return titleFromChangeId(changeId.get()); ++ } ++ ++ return Optional.empty(); ++ } ++ ++ private static final Pattern extractChangeIdRegex = Pattern.compile("^/(?:c/.*/\\+/)?(?<changeId>[0-9]+)(?:/[0-9]+)?(?:/.*)?$"); ++ private final Provider<ChangesCollection> changes; ++ ++ private Optional<Change.Id> tryExtractChange(String path) { ++ Matcher m = extractChangeIdRegex.matcher(path); ++ if (!m.matches()) { ++ return Optional.empty(); ++ } ++ return Change.Id.tryParse(m.group("changeId")); ++ } ++ ++ private Optional<String> titleFromChangeId(Change.Id changeId) { ++ ChangesCollection changesCollection = changes.get(); ++ try { ++ ChangeResource changeResource = changesCollection.parse(changeId); ++ return Optional.of(changeResource.getChange().getSubject()); ++ } catch (ResourceConflictException | ResourceNotFoundException | PermissionBackendException e) { ++ return Optional.empty(); ++ } ++ } ++} +diff --git a/resources/com/google/gerrit/httpd/raw/PolyGerritIndexHtml.soy b/resources/com/google/gerrit/httpd/raw/PolyGerritIndexHtml.soy +index dbfef44dfe..347ee75aab 100644 +--- a/resources/com/google/gerrit/httpd/raw/PolyGerritIndexHtml.soy ++++ b/resources/com/google/gerrit/httpd/raw/PolyGerritIndexHtml.soy +@@ -33,10 +33,12 @@ + {@param? defaultDashboardHex: ?} + {@param? dashboardQuery: ?} + {@param? userIsAuthenticated: ?} ++ {@param? title: ?} + <!DOCTYPE html>{\n} + <html lang="en">{\n} + <meta charset="utf-8">{\n} +- <meta name="description" content="Gerrit Code Review">{\n} ++ {if $title}<title>{$title} · Gerrit Code Review</title>{\n}{/if} ++ <meta name="description" content="{if $title}{$title} · {/if}Gerrit Code Review">{\n} + <meta name="referrer" content="never">{\n} + <meta name="viewport" content="width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0">{\n} + +-- +2.37.3 + diff --git a/third_party/gerrit/default.nix b/third_party/gerrit/default.nix new file mode 100644 index 0000000000..ef3e628a1e --- /dev/null +++ b/third_party/gerrit/default.nix @@ -0,0 +1,158 @@ +{ depot, pkgs, ... }: + +let + bazelRunScript = pkgs.writeShellScriptBin "bazel-run" '' + yarn config set cache-folder "$bazelOut/external/yarn_cache" + export HOME="$bazelOut/external/home" + mkdir -p "$bazelOut/external/home" + exec /bin/bazel "$@" + ''; + bazelTop = pkgs.buildFHSUserEnv { + name = "bazel"; + targetPkgs = pkgs: [ + (pkgs.bazel_5.override { enableNixHacks = true; }) + pkgs.jdk11_headless + pkgs.zlib + pkgs.python3 + pkgs.curl + pkgs.nodejs + pkgs.yarn + pkgs.git + bazelRunScript + ]; + runScript = "/bin/bazel-run"; + }; + bazel = bazelTop // { override = x: bazelTop; }; + version = "3.8.2"; +in +pkgs.lib.makeOverridable pkgs.buildBazelPackage { + pname = "gerrit"; + inherit version; + + src = pkgs.fetchgit { + url = "https://gerrit.googlesource.com/gerrit"; + rev = "67500d39b5bceee8f3ae8b9d605f01428aacb740"; + branchName = "v${version}"; + sha256 = "sha256:06bmzbcb9717s4b016kcbn8nr9pgaz04i8bnzg7ybkbdwpl8vxvl"; + fetchSubmodules = true; + }; + + patches = [ + ./0001-Syntax-highlight-nix.patch + ./0002-Syntax-highlight-rules.pl.patch + ./0003-Add-titles-to-CLs-over-HTTP.patch + ]; + + bazelTargets = [ "release" "api-skip-javadoc" ]; + inherit bazel; + + bazelFlags = [ + "--repository_cache=" + "--disk_cache=" + ]; + + removeRulesCC = false; + fetchConfigured = true; + + fetchAttrs = { + sha256 = "sha256:1syy44n1nvrlypa8jv83yzf0miwmsn8bvh97js6v5ygllx04mvf1"; + preBuild = '' + rm .bazelversion + ''; + + installPhase = '' + runHook preInstall + + # Remove all built in external workspaces, Bazel will recreate them when building + rm -rf $bazelOut/external/{bazel_tools,\@bazel_tools.marker} + rm -rf $bazelOut/external/{embedded_jdk,\@embedded_jdk.marker} + rm -rf $bazelOut/external/{local_config_cc,\@local_config_cc.marker} + rm -rf $bazelOut/external/{local_*,\@local_*.marker} + + # Clear markers + find $bazelOut/external -name '@*\.marker' -exec sh -c 'echo > {}' \; + + # Remove all vcs files + rm -rf $(find $bazelOut/external -type d -name .git) + rm -rf $(find $bazelOut/external -type d -name .svn) + rm -rf $(find $bazelOut/external -type d -name .hg) + + # Removing top-level symlinks along with their markers. + # This is needed because they sometimes point to temporary paths (?). + # For example, in Tensorflow-gpu build: + # platforms -> NIX_BUILD_TOP/tmp/install/35282f5123611afa742331368e9ae529/_embedded_binaries/platforms + find $bazelOut/external -maxdepth 1 -type l | while read symlink; do + name="$(basename "$symlink")" + rm -rf "$symlink" "$bazelOut/external/@$name.marker" + done + + # Patching symlinks to remove build directory reference + find $bazelOut/external -type l | while read symlink; do + new_target="$(readlink "$symlink" | sed "s,$NIX_BUILD_TOP,NIX_BUILD_TOP,")" + rm "$symlink" + ln -sf "$new_target" "$symlink" + done + + echo '${bazel.name}' > $bazelOut/external/.nix-bazel-version + + # Gerrit fixups: + # Normalize permissions on .yarn-{tarball,metadata} files + test -d $bazelOut/external/yarn_cache && find $bazelOut/external/yarn_cache \( -name .yarn-tarball.tgz -or -name .yarn-metadata.json \) -exec chmod 644 {} + + + mkdir $bazelOut/_bits/ + find . -name node_modules -prune -print | while read d; do + echo "$d" "$(dirname $d)" + mkdir -p $bazelOut/_bits/$(dirname $d) + cp -R "$d" "$bazelOut/_bits/$(dirname $d)/node_modules" + done + + (cd $bazelOut/ && tar czf $out --sort=name --mtime='@1' --owner=0 --group=0 --numeric-owner external/ _bits/) + + runHook postInstall + ''; + }; + + buildAttrs = { + preConfigure = '' + rm .bazelversion + + [ "$(ls -A $bazelOut/_bits)" ] && cp -R $bazelOut/_bits/* ./ || true + ''; + postPatch = '' + # Disable all errorprone checks, since we might be using a different version. + sed -i \ + -e '/-Xep:/d' \ + -e '/-XepExcludedPaths:/a "-XepDisableAllChecks",' \ + tools/BUILD + ''; + installPhase = '' + mkdir -p "$out"/webapps/ "$out"/share/api/ + cp bazel-bin/release.war "$out"/webapps/gerrit-${version}.war + unzip bazel-bin/api-skip-javadoc.zip -d "$out"/share/api + ''; + + nativeBuildInputs = with pkgs; [ + unzip + ]; + }; + + passthru = { + # A list of plugins that are part of the gerrit.war file. + # Use `java -jar gerrit.war ls | grep -Po '(?<=plugins/)[^.]+' | sed -e 's,^,",' -e 's,$,",' | sort` to generate that list. + plugins = [ + "codemirror-editor" + "commit-message-length-validator" + "delete-project" + "download-commands" + "gitiles" + "hooks" + "plugin-manager" + "replication" + "reviewnotes" + "singleusergroup" + "webhooks" + ]; + }; + + meta.ci.targets = [ "deps" ]; +} diff --git a/third_party/gerrit/detzip.go b/third_party/gerrit/detzip.go new file mode 100644 index 0000000000..511c18ecfe --- /dev/null +++ b/third_party/gerrit/detzip.go @@ -0,0 +1,97 @@ +package main + +import ( + "archive/zip" + "flag" + "fmt" + "io" + "log" + "os" + "path/filepath" + "sort" + "strings" +) + +var ( + exclude = flag.String("exclude", "", "comma-separated list of filenames to exclude (in any directory)") +) + +func init() { + flag.Usage = func() { + fmt.Fprintf(flag.CommandLine.Output(), "Usage of %s [zip file] [directory]:\n", os.Args[0]) + flag.PrintDefaults() + } +} + +func listToMap(ss []string) map[string]bool { + m := make(map[string]bool) + for _, s := range ss { + m[s] = true + } + return m +} + +func main() { + flag.Parse() + if flag.NArg() != 2 { + flag.Usage() + os.Exit(1) + } + + outPath := flag.Arg(0) + dirPath := flag.Arg(1) + + excludeFiles := listToMap(strings.Split(*exclude, ",")) + + // Aggregate all files first. + var files []string + filepath.Walk(dirPath, func(path string, info os.FileInfo, err error) error { + if err != nil { + return err + } + if info.IsDir() { + return nil + } + if excludeFiles[info.Name()] { + return nil + } + files = append(files, path) + return nil + }) + + // Create zip + outW, err := os.Create(outPath) + if err != nil { + log.Fatalf("Create(%q): %v", outPath, err) + } + + zipW := zip.NewWriter(outW) + + // Output files in alphabetical order + sort.Strings(files) + for _, f := range files { + fw, err := zipW.CreateHeader(&zip.FileHeader{ + Name: f, + Method: zip.Store, + }) + if err != nil { + log.Fatalf("creating %q in zip: %v", f, err) + } + + ff, err := os.Open(f) + if err != nil { + log.Fatalf("opening %q: %v", f, err) + } + if _, err := io.Copy(fw, ff); err != nil { + log.Fatalf("copying %q to zip: %v", f, err) + } + ff.Close() + } + + if err := zipW.Close(); err != nil { + log.Fatalf("writing ZIP central directory: %v", err) + } + if err := outW.Close(); err != nil { + log.Fatalf("closing ZIP file: %v", err) + } +} diff --git a/third_party/gerrit_plugins/builder.nix b/third_party/gerrit_plugins/builder.nix new file mode 100644 index 0000000000..50a4e78ae7 --- /dev/null +++ b/third_party/gerrit_plugins/builder.nix @@ -0,0 +1,39 @@ +{ depot, lib, pkgs, ... }: +{ + buildGerritBazelPlugin = + { name + , src + , depsOutputHash + , overlayPluginCmd ? '' + cp -R "${src}" "$out/plugins/${name}" + '' + , postPatch ? "" + , patches ? [ ] + }: ((depot.third_party.gerrit.override { + name = "${name}.jar"; + + src = pkgs.runCommandLocal "${name}-src" { } '' + cp -R "${depot.third_party.gerrit.src}" "$out" + chmod +w "$out/plugins" + ${overlayPluginCmd} + ''; + + bazelTargets = [ "//plugins/${name}" ]; + }).overrideAttrs (super: { + deps = super.deps.overrideAttrs (superDeps: { + outputHash = depsOutputHash; + }); + installPhase = '' + cp "bazel-bin/plugins/${name}/${name}.jar" "$out" + ''; + postPatch = '' + ${super.postPatch or ""} + pushd "plugins/${name}" + ${lib.concatMapStringsSep "\n" (patch: '' + patch -p1 < ${patch} + '') patches} + popd + ${postPatch} + ''; + })); +} diff --git a/third_party/gerrit_plugins/code-owners/default.nix b/third_party/gerrit_plugins/code-owners/default.nix new file mode 100644 index 0000000000..d35a158279 --- /dev/null +++ b/third_party/gerrit_plugins/code-owners/default.nix @@ -0,0 +1,17 @@ +{ depot, pkgs, ... }@args: + +let + inherit (import ../builder.nix args) buildGerritBazelPlugin; +in +buildGerritBazelPlugin rec { + name = "code-owners"; + depsOutputHash = "sha256:1hd63b54zkgv8j7323inp7rdnhs2jdsb232jqlwsd9pai2f12m7n"; + src = pkgs.fetchgit { + url = "https://gerrit.googlesource.com/plugins/code-owners"; + rev = "e654ae5bda2085bce9a99942bec440e004a114f3"; + sha256 = "sha256:14d3x3iqskgw16pvyaa0swh252agj84p9pzlf24l8lgx9d7y4biz"; + }; + patches = [ + ./using-usernames.patch + ]; +} diff --git a/third_party/gerrit_plugins/code-owners/using-usernames.patch b/third_party/gerrit_plugins/code-owners/using-usernames.patch new file mode 100644 index 0000000000..25079ae136 --- /dev/null +++ b/third_party/gerrit_plugins/code-owners/using-usernames.patch @@ -0,0 +1,472 @@ +commit 29ace6c38ac513f7ec56ca425230d5712c081043 +Author: Luke Granger-Brown <git@lukegb.com> +Date: Wed Sep 21 03:15:38 2022 +0100 + + Add support for usernames and groups + + Change-Id: I3ba8527f66216d08e555a6ac4451fe0d1e090de5 + +diff --git a/java/com/google/gerrit/plugins/codeowners/backend/CodeOwnerResolver.java b/java/com/google/gerrit/plugins/codeowners/backend/CodeOwnerResolver.java +index 70009591..6dc596c9 100644 +--- a/java/com/google/gerrit/plugins/codeowners/backend/CodeOwnerResolver.java ++++ b/java/com/google/gerrit/plugins/codeowners/backend/CodeOwnerResolver.java +@@ -17,6 +17,8 @@ package com.google.gerrit.plugins.codeowners.backend; + import static com.google.common.base.Preconditions.checkState; + import static com.google.common.collect.ImmutableMap.toImmutableMap; + import static com.google.common.collect.ImmutableSet.toImmutableSet; ++import static com.google.common.collect.ImmutableSetMultimap.flatteningToImmutableSetMultimap; ++import static com.google.common.collect.ImmutableSetMultimap.toImmutableSetMultimap; + import static com.google.gerrit.plugins.codeowners.backend.CodeOwnersInternalServerErrorException.newInternalServerError; + import static java.util.Objects.requireNonNull; + +@@ -25,6 +27,7 @@ import com.google.common.collect.ImmutableList; + import com.google.common.collect.ImmutableMap; + import com.google.common.collect.ImmutableMultimap; + import com.google.common.collect.ImmutableSet; ++import com.google.common.collect.ImmutableSetMultimap; + import com.google.common.collect.Iterables; + import com.google.common.collect.Streams; + import com.google.common.flogger.FluentLogger; +@@ -33,17 +36,24 @@ import com.google.gerrit.entities.Project; + import com.google.gerrit.metrics.Timer0; + import com.google.gerrit.plugins.codeowners.backend.config.CodeOwnersPluginConfiguration; + import com.google.gerrit.plugins.codeowners.metrics.CodeOwnerMetrics; ++import com.google.gerrit.server.AnonymousUser; + import com.google.gerrit.server.CurrentUser; + import com.google.gerrit.server.IdentifiedUser; + import com.google.gerrit.server.account.AccountCache; + import com.google.gerrit.server.account.AccountControl; + import com.google.gerrit.server.account.AccountState; ++import com.google.gerrit.server.account.GroupBackend; ++import com.google.gerrit.server.account.GroupBackends; ++import com.google.gerrit.server.account.InternalGroupBackend; + import com.google.gerrit.server.account.externalids.ExternalId; + import com.google.gerrit.server.account.externalids.ExternalIdCache; + import com.google.gerrit.server.permissions.GlobalPermission; + import com.google.gerrit.server.permissions.PermissionBackend; + import com.google.gerrit.server.permissions.PermissionBackendException; ++import com.google.gerrit.server.util.RequestContext; ++import com.google.gerrit.server.util.ThreadLocalRequestContext; + import com.google.inject.Inject; ++import com.google.inject.OutOfScopeException; + import com.google.inject.Provider; + import java.io.IOException; + import java.nio.file.Path; +@@ -102,6 +112,8 @@ public class CodeOwnerResolver { + + @VisibleForTesting public static final String ALL_USERS_WILDCARD = "*"; + ++ public static final String GROUP_PREFIX = "group:"; ++ + private final CodeOwnersPluginConfiguration codeOwnersPluginConfiguration; + private final PermissionBackend permissionBackend; + private final Provider<CurrentUser> currentUser; +@@ -112,6 +124,8 @@ public class CodeOwnerResolver { + private final CodeOwnerMetrics codeOwnerMetrics; + private final UnresolvedImportFormatter unresolvedImportFormatter; + private final TransientCodeOwnerCache transientCodeOwnerCache; ++ private final InternalGroupBackend groupBackend; ++ private final ThreadLocalRequestContext context; + + // Enforce visibility by default. + private boolean enforceVisibility = true; +@@ -132,7 +146,9 @@ public class CodeOwnerResolver { + PathCodeOwners.Factory pathCodeOwnersFactory, + CodeOwnerMetrics codeOwnerMetrics, + UnresolvedImportFormatter unresolvedImportFormatter, +- TransientCodeOwnerCache transientCodeOwnerCache) { ++ TransientCodeOwnerCache transientCodeOwnerCache, ++ InternalGroupBackend groupBackend, ++ ThreadLocalRequestContext context) { + this.codeOwnersPluginConfiguration = codeOwnersPluginConfiguration; + this.permissionBackend = permissionBackend; + this.currentUser = currentUser; +@@ -143,6 +159,8 @@ public class CodeOwnerResolver { + this.codeOwnerMetrics = codeOwnerMetrics; + this.unresolvedImportFormatter = unresolvedImportFormatter; + this.transientCodeOwnerCache = transientCodeOwnerCache; ++ this.groupBackend = groupBackend; ++ this.context = context; + } + + /** +@@ -361,6 +379,12 @@ public class CodeOwnerResolver { + "cannot resolve code owner email %s: no account with this email exists", + CodeOwnerResolver.ALL_USERS_WILDCARD)); + } ++ if (codeOwnerReference.email().startsWith(GROUP_PREFIX)) { ++ return OptionalResultWithMessages.createEmpty( ++ String.format( ++ "cannot resolve code owner email %s: this is a group", ++ codeOwnerReference.email())); ++ } + + ImmutableList.Builder<String> messageBuilder = ImmutableList.builder(); + AtomicBoolean ownedByAllUsers = new AtomicBoolean(false); +@@ -405,9 +429,53 @@ public class CodeOwnerResolver { + ImmutableMultimap<CodeOwnerReference, CodeOwnerAnnotation> annotations) { + requireNonNull(codeOwnerReferences, "codeOwnerReferences"); + ++ ImmutableSet<String> groupsToResolve = ++ codeOwnerReferences.stream() ++ .map(CodeOwnerReference::email) ++ .filter(ref -> ref.startsWith(GROUP_PREFIX)) ++ .map(ref -> ref.substring(GROUP_PREFIX.length())) ++ .collect(toImmutableSet()); ++ ++ // When we call GroupBackends.findExactSuggestion we need to ensure that we ++ // have a user in context. This is because the suggestion backend is ++ // likely to want to try to check that we can actually see the group it's ++ // returning (which we also check for explicitly, because I have trust ++ // issues). ++ RequestContext oldCtx = context.getContext(); ++ // Check if we have a user in the context at all... ++ try { ++ oldCtx.getUser(); ++ } catch (OutOfScopeException | NullPointerException e) { ++ // Nope. ++ RequestContext newCtx = () -> { ++ return new AnonymousUser(); ++ }; ++ context.setContext(newCtx); ++ } ++ ImmutableSetMultimap<String, CodeOwner> resolvedGroups = null; ++ try { ++ resolvedGroups = ++ groupsToResolve.stream() ++ .map(groupName -> GroupBackends.findExactSuggestion(groupBackend, groupName)) ++ .filter(groupRef -> groupRef != null) ++ .filter(groupRef -> groupBackend.isVisibleToAll(groupRef.getUUID())) ++ .map(groupRef -> groupBackend.get(groupRef.getUUID())) ++ .collect(flatteningToImmutableSetMultimap( ++ groupRef -> GROUP_PREFIX + groupRef.getName(), ++ groupRef -> accountCache ++ .get(ImmutableSet.copyOf(groupRef.getMembers())) ++ .values().stream() ++ .map(accountState -> CodeOwner.create(accountState.account().id())))); ++ } finally { ++ context.setContext(oldCtx); ++ } ++ ImmutableSetMultimap<CodeOwner, String> usersToGroups = ++ resolvedGroups.inverse(); ++ + ImmutableSet<String> emailsToResolve = + codeOwnerReferences.stream() + .map(CodeOwnerReference::email) ++ .filter(ref -> !ref.startsWith(GROUP_PREFIX)) + .filter(filterOutAllUsersWildCard(ownedByAllUsers)) + .collect(toImmutableSet()); + +@@ -442,7 +510,8 @@ public class CodeOwnerResolver { + ImmutableMap<String, CodeOwner> codeOwnersByEmail = + accountsByEmail.map(mapToCodeOwner()).collect(toImmutableMap(Pair::key, Pair::value)); + +- if (codeOwnersByEmail.keySet().size() < emailsToResolve.size()) { ++ if (codeOwnersByEmail.keySet().size() < emailsToResolve.size() || ++ resolvedGroups.keySet().size() < groupsToResolve.size()) { + hasUnresolvedCodeOwners.set(true); + } + +@@ -456,7 +525,9 @@ public class CodeOwnerResolver { + cachedCodeOwnersByEmail.entrySet().stream() + .filter(e -> e.getValue().isPresent()) + .map(e -> Pair.of(e.getKey(), e.getValue().get())); +- Streams.concat(newlyResolvedCodeOwnersStream, cachedCodeOwnersStream) ++ Stream<Pair<String, CodeOwner>> resolvedGroupsCodeOwnersStream = ++ resolvedGroups.entries().stream().map(e -> Pair.of(e.getKey(), e.getValue())); ++ Streams.concat(Streams.concat(newlyResolvedCodeOwnersStream, cachedCodeOwnersStream), resolvedGroupsCodeOwnersStream) + .forEach( + p -> { + ImmutableSet.Builder<CodeOwnerAnnotation> annotationBuilder = ImmutableSet.builder(); +@@ -467,6 +538,12 @@ public class CodeOwnerResolver { + annotationBuilder.addAll( + annotations.get(CodeOwnerReference.create(ALL_USERS_WILDCARD))); + ++ // annotations for the groups this user is in apply as well ++ for (String group : usersToGroups.get(p.value())) { ++ annotationBuilder.addAll( ++ annotations.get(CodeOwnerReference.create(group))); ++ } ++ + if (!codeOwnersWithAnnotations.containsKey(p.value())) { + codeOwnersWithAnnotations.put(p.value(), new HashSet<>()); + } +@@ -570,7 +647,7 @@ public class CodeOwnerResolver { + } + + messages.add(String.format("email %s has no domain", email)); +- return false; ++ return true; // TVL: we allow domain-less strings which are treated as usernames. + } + + /** +@@ -585,11 +662,29 @@ public class CodeOwnerResolver { + */ + private ImmutableMap<String, Collection<ExternalId>> lookupExternalIds( + ImmutableList.Builder<String> messages, ImmutableSet<String> emails) { ++ String[] actualEmails = emails.stream() ++ .filter(email -> email.contains("@")) ++ .toArray(String[]::new); ++ ImmutableSet<String> usernames = emails.stream() ++ .filter(email -> !email.contains("@")) ++ .collect(ImmutableSet.toImmutableSet()); + try { +- ImmutableMap<String, Collection<ExternalId>> extIdsByEmail = +- externalIdCache.byEmails(emails.toArray(new String[0])).asMap(); ++ ImmutableMap<String, Collection<ExternalId>> extIds = ++ new ImmutableMap.Builder<String, Collection<ExternalId>>() ++ .putAll(externalIdCache.byEmails(actualEmails).asMap()) ++ .putAll(externalIdCache.allByAccount().entries().stream() ++ .map(entry -> entry.getValue()) ++ .filter(externalId -> ++ externalId.key().scheme() != null && ++ externalId.key().isScheme(ExternalId.SCHEME_USERNAME) && ++ usernames.contains(externalId.key().id())) ++ .collect(toImmutableSetMultimap( ++ externalId -> externalId.key().id(), ++ externalId -> externalId)) ++ .asMap()) ++ .build(); + emails.stream() +- .filter(email -> !extIdsByEmail.containsKey(email)) ++ .filter(email -> !extIds.containsKey(email)) + .forEach( + email -> { + transientCodeOwnerCache.cacheNonResolvable(email); +@@ -598,7 +693,7 @@ public class CodeOwnerResolver { + "cannot resolve code owner email %s: no account with this email exists", + email)); + }); +- return extIdsByEmail; ++ return extIds; + } catch (IOException e) { + throw newInternalServerError( + String.format("cannot resolve code owner emails: %s", emails), e); +@@ -815,6 +910,15 @@ public class CodeOwnerResolver { + user != null ? user.getLoggableName() : currentUser.get().getLoggableName())); + return true; + } ++ if (!email.contains("@")) { ++ // the email is the username of the account, or a group, or something else. ++ messages.add( ++ String.format( ++ "account %s is visible to user %s", ++ accountState.account().id(), ++ user != null ? user.getLoggableName() : currentUser.get().getLoggableName())); ++ return true; ++ } + + if (user != null) { + if (user.hasEmailAddress(email)) { +diff --git a/java/com/google/gerrit/plugins/codeowners/backend/findowners/FindOwnersCodeOwnerConfigParser.java b/java/com/google/gerrit/plugins/codeowners/backend/findowners/FindOwnersCodeOwnerConfigParser.java +index 5f350998..7977ba55 100644 +--- a/java/com/google/gerrit/plugins/codeowners/backend/findowners/FindOwnersCodeOwnerConfigParser.java ++++ b/java/com/google/gerrit/plugins/codeowners/backend/findowners/FindOwnersCodeOwnerConfigParser.java +@@ -149,7 +149,8 @@ public class FindOwnersCodeOwnerConfigParser implements CodeOwnerConfigParser { + private static final String EOL = "[\\s]*(#.*)?$"; // end-of-line + private static final String GLOB = "[^\\s,=]+"; // a file glob + +- private static final String EMAIL_OR_STAR = "([^\\s<>@,]+@[^\\s<>@#,]+|\\*)"; ++ // Also allows usernames, and group:$GROUP_NAME. ++ private static final String EMAIL_OR_STAR = "([^\\s<>@,]+@[^\\s<>@#,]+?|\\*|[a-zA-Z0-9_\\-]+|group:[a-zA-Z0-9_\\-]+)"; + private static final String EMAIL_LIST = + "(" + EMAIL_OR_STAR + "(" + COMMA + EMAIL_OR_STAR + ")*)"; + +diff --git a/javatests/com/google/gerrit/plugins/codeowners/backend/AbstractFileBasedCodeOwnerBackendTest.java b/javatests/com/google/gerrit/plugins/codeowners/backend/AbstractFileBasedCodeOwnerBackendTest.java +index 7ec92959..59cf7e05 100644 +--- a/javatests/com/google/gerrit/plugins/codeowners/backend/AbstractFileBasedCodeOwnerBackendTest.java ++++ b/javatests/com/google/gerrit/plugins/codeowners/backend/AbstractFileBasedCodeOwnerBackendTest.java +@@ -424,7 +424,7 @@ public abstract class AbstractFileBasedCodeOwnerBackendTest extends AbstractCode + .commit() + .parent(head) + .message("Add invalid test code owner config") +- .add(JgitPath.of(codeOwnerConfigKey.filePath(getFileName())).get(), "INVALID")); ++ .add(JgitPath.of(codeOwnerConfigKey.filePath(getFileName())).get(), "INVALID!")); + } + + // Try to update the code owner config. +diff --git a/javatests/com/google/gerrit/plugins/codeowners/backend/CodeOwnerResolverTest.java b/javatests/com/google/gerrit/plugins/codeowners/backend/CodeOwnerResolverTest.java +index 6171aca9..37699012 100644 +--- a/javatests/com/google/gerrit/plugins/codeowners/backend/CodeOwnerResolverTest.java ++++ b/javatests/com/google/gerrit/plugins/codeowners/backend/CodeOwnerResolverTest.java +@@ -24,8 +24,10 @@ import com.google.gerrit.acceptance.TestAccount; + import com.google.gerrit.acceptance.TestMetricMaker; + import com.google.gerrit.acceptance.config.GerritConfig; + import com.google.gerrit.acceptance.testsuite.account.AccountOperations; ++import com.google.gerrit.acceptance.testsuite.group.GroupOperations; + import com.google.gerrit.acceptance.testsuite.request.RequestScopeOperations; + import com.google.gerrit.entities.Account; ++import com.google.gerrit.entities.AccountGroup; + import com.google.gerrit.plugins.codeowners.acceptance.AbstractCodeOwnersTest; + import com.google.gerrit.server.ServerInitiated; + import com.google.gerrit.server.account.AccountsUpdate; +@@ -51,6 +53,7 @@ public class CodeOwnerResolverTest extends AbstractCodeOwnersTest { + @Inject private RequestScopeOperations requestScopeOperations; + @Inject @ServerInitiated private Provider<AccountsUpdate> accountsUpdate; + @Inject private AccountOperations accountOperations; ++ @Inject private GroupOperations groupOperations; + @Inject private ExternalIdNotes.Factory externalIdNotesFactory; + @Inject private TestMetricMaker testMetricMaker; + @Inject private ExternalIdFactory externalIdFactory; +@@ -112,6 +115,18 @@ public class CodeOwnerResolverTest extends AbstractCodeOwnersTest { + .contains(String.format("account %s is visible to user %s", admin.id(), admin.username())); + } + ++ @Test ++ public void resolveCodeOwnerReferenceForUsername() throws Exception { ++ OptionalResultWithMessages<CodeOwner> result = ++ codeOwnerResolverProvider ++ .get() ++ .resolveWithMessages(CodeOwnerReference.create(admin.username())); ++ assertThat(result.get()).hasAccountIdThat().isEqualTo(admin.id()); ++ assertThat(result) ++ .hasMessagesThat() ++ .contains(String.format("account %s is visible to user %s", admin.id(), admin.username())); ++ } ++ + @Test + public void cannotResolveCodeOwnerReferenceForStarAsEmail() throws Exception { + OptionalResultWithMessages<CodeOwner> result = +@@ -127,6 +142,18 @@ public class CodeOwnerResolverTest extends AbstractCodeOwnersTest { + CodeOwnerResolver.ALL_USERS_WILDCARD)); + } + ++ @Test ++ public void cannotResolveCodeOwnerReferenceForGroup() throws Exception { ++ OptionalResultWithMessages<CodeOwner> result = ++ codeOwnerResolverProvider ++ .get() ++ .resolveWithMessages(CodeOwnerReference.create("group:Administrators")); ++ assertThat(result).isEmpty(); ++ assertThat(result) ++ .hasMessagesThat() ++ .contains("cannot resolve code owner email group:Administrators: this is a group"); ++ } ++ + @Test + public void resolveCodeOwnerReferenceForAmbiguousEmailIfOtherAccountIsInactive() + throws Exception { +@@ -397,6 +424,64 @@ public class CodeOwnerResolverTest extends AbstractCodeOwnersTest { + assertThat(result.hasUnresolvedCodeOwners()).isFalse(); + } + ++ @Test ++ public void resolvePathCodeOwnersWhenNonVisibleGroupIsUsed() throws Exception { ++ CodeOwnerConfig codeOwnerConfig = ++ CodeOwnerConfig.builder(CodeOwnerConfig.Key.create(project, "master", "/"), TEST_REVISION) ++ .addCodeOwnerSet( ++ CodeOwnerSet.createWithoutPathExpressions("group:Administrators")) ++ .build(); ++ ++ CodeOwnerResolverResult result = ++ codeOwnerResolverProvider ++ .get() ++ .resolvePathCodeOwners(codeOwnerConfig, Paths.get("/README.md")); ++ assertThat(result.codeOwnersAccountIds()).isEmpty(); ++ assertThat(result.ownedByAllUsers()).isFalse(); ++ assertThat(result.hasUnresolvedCodeOwners()).isTrue(); ++ } ++ ++ @Test ++ public void resolvePathCodeOwnersWhenVisibleGroupIsUsed() throws Exception { ++ AccountGroup.UUID createdGroupUUID = groupOperations ++ .newGroup() ++ .name("VisibleGroup") ++ .visibleToAll(true) ++ .addMember(admin.id()) ++ .create(); ++ ++ CodeOwnerConfig codeOwnerConfig = ++ CodeOwnerConfig.builder(CodeOwnerConfig.Key.create(project, "master", "/"), TEST_REVISION) ++ .addCodeOwnerSet( ++ CodeOwnerSet.createWithoutPathExpressions("group:VisibleGroup")) ++ .build(); ++ ++ CodeOwnerResolverResult result = ++ codeOwnerResolverProvider ++ .get() ++ .resolvePathCodeOwners(codeOwnerConfig, Paths.get("/README.md")); ++ assertThat(result.codeOwnersAccountIds()).containsExactly(admin.id()); ++ assertThat(result.ownedByAllUsers()).isFalse(); ++ assertThat(result.hasUnresolvedCodeOwners()).isFalse(); ++ } ++ ++ @Test ++ public void resolvePathCodeOwnersWhenUsernameIsUsed() throws Exception { ++ CodeOwnerConfig codeOwnerConfig = ++ CodeOwnerConfig.builder(CodeOwnerConfig.Key.create(project, "master", "/"), TEST_REVISION) ++ .addCodeOwnerSet( ++ CodeOwnerSet.createWithoutPathExpressions(admin.username())) ++ .build(); ++ ++ CodeOwnerResolverResult result = ++ codeOwnerResolverProvider ++ .get() ++ .resolvePathCodeOwners(codeOwnerConfig, Paths.get("/README.md")); ++ assertThat(result.codeOwnersAccountIds()).containsExactly(admin.id()); ++ assertThat(result.ownedByAllUsers()).isFalse(); ++ assertThat(result.hasUnresolvedCodeOwners()).isFalse(); ++ } ++ + @Test + public void resolvePathCodeOwnersNonResolvableCodeOwnersAreFilteredOut() throws Exception { + CodeOwnerConfig codeOwnerConfig = +@@ -655,7 +740,7 @@ public class CodeOwnerResolverTest extends AbstractCodeOwnersTest { + "domain example.com of email foo@example.org@example.com is allowed"); + assertIsEmailDomainAllowed( + "foo@example.org", false, "domain example.org of email foo@example.org is not allowed"); +- assertIsEmailDomainAllowed("foo", false, "email foo has no domain"); ++ assertIsEmailDomainAllowed("foo", true, "email foo has no domain"); + assertIsEmailDomainAllowed( + "foo@example.com@example.org", + false, +diff --git a/javatests/com/google/gerrit/plugins/codeowners/backend/findowners/FindOwnersCodeOwnerConfigParserTest.java b/javatests/com/google/gerrit/plugins/codeowners/backend/findowners/FindOwnersCodeOwnerConfigParserTest.java +index 260e635e..7aab99d0 100644 +--- a/javatests/com/google/gerrit/plugins/codeowners/backend/findowners/FindOwnersCodeOwnerConfigParserTest.java ++++ b/javatests/com/google/gerrit/plugins/codeowners/backend/findowners/FindOwnersCodeOwnerConfigParserTest.java +@@ -158,16 +158,42 @@ public class FindOwnersCodeOwnerConfigParserTest extends AbstractCodeOwnerConfig + codeOwnerConfigParser.parse( + TEST_REVISION, + CodeOwnerConfig.Key.create(project, "master", "/"), +- getCodeOwnerConfig(EMAIL_1, "INVALID", "NOT_AN_EMAIL", EMAIL_2))); ++ getCodeOwnerConfig(EMAIL_1, "INVALID!", "NOT!AN_EMAIL", EMAIL_2))); + assertThat(exception.getFullMessage(FindOwnersBackend.CODE_OWNER_CONFIG_FILE_NAME)) + .isEqualTo( + String.format( + "invalid code owner config file '/OWNERS' (project = %s, branch = master):\n" +- + " invalid line: INVALID\n" +- + " invalid line: NOT_AN_EMAIL", ++ + " invalid line: INVALID!\n" ++ + " invalid line: NOT!AN_EMAIL", + project)); + } + ++ @Test ++ public void codeOwnerConfigWithUsernames() throws Exception { ++ assertParseAndFormat( ++ getCodeOwnerConfig(EMAIL_1, "USERNAME", EMAIL_2), ++ codeOwnerConfig -> ++ assertThat(codeOwnerConfig) ++ .hasCodeOwnerSetsThat() ++ .onlyElement() ++ .hasCodeOwnersEmailsThat() ++ .containsExactly(EMAIL_1, "USERNAME", EMAIL_2), ++ getCodeOwnerConfig(EMAIL_1, "USERNAME", EMAIL_2)); ++ } ++ ++ @Test ++ public void codeOwnerConfigWithGroups() throws Exception { ++ assertParseAndFormat( ++ getCodeOwnerConfig(EMAIL_1, "group:tvl-employees", EMAIL_2), ++ codeOwnerConfig -> ++ assertThat(codeOwnerConfig) ++ .hasCodeOwnerSetsThat() ++ .onlyElement() ++ .hasCodeOwnersEmailsThat() ++ .containsExactly(EMAIL_1, "group:tvl-employees", EMAIL_2), ++ getCodeOwnerConfig(EMAIL_1, "group:tvl-employees", EMAIL_2)); ++ } ++ + @Test + public void codeOwnerConfigWithComment() throws Exception { + assertParseAndFormat( diff --git a/third_party/gerrit_plugins/oauth/default.nix b/third_party/gerrit_plugins/oauth/default.nix new file mode 100644 index 0000000000..71936bf82e --- /dev/null +++ b/third_party/gerrit_plugins/oauth/default.nix @@ -0,0 +1,19 @@ +{ depot, pkgs, ... }@args: + +let + inherit (import ../builder.nix args) buildGerritBazelPlugin; +in +buildGerritBazelPlugin rec { + name = "oauth"; + depsOutputHash = "sha256:16lv1glsfkn2bagx0vs6sgjf1mdd8vf3dl3iby1zvcm3wnrwfz7y"; + src = pkgs.fetchgit { + url = "https://gerrit.googlesource.com/plugins/oauth"; + rev = "f9bef7476bc99f7b1dc3fe2d52ec95cd7ac571dc"; + sha256 = "08wf50bz7ash37mzlrxfy7hvmjsf6s4ncpcw5969hs9hjvjfj4dz"; + }; + overlayPluginCmd = '' + chmod +w "$out" "$out/plugins/external_plugin_deps.bzl" + cp -R "${src}" "$out/plugins/${name}" + cp "${src}/external_plugin_deps.bzl" "$out/plugins/external_plugin_deps.bzl" + ''; +} diff --git a/third_party/git/0001-feat-third_party-git-date-add-dottime-format.patch b/third_party/git/0001-feat-third_party-git-date-add-dottime-format.patch new file mode 100644 index 0000000000..a249b1ce1b --- /dev/null +++ b/third_party/git/0001-feat-third_party-git-date-add-dottime-format.patch @@ -0,0 +1,119 @@ +From 2fd675c5379dcfa7a2c3465e325cdea8faa2b95c Mon Sep 17 00:00:00 2001 +From: Vincent Ambo <tazjin@google.com> +Date: Mon, 6 Jan 2020 16:00:52 +0000 +Subject: [PATCH] feat(third_party/git/date): add "dottime" format + +Adds dottime (as defined on https://dotti.me) as a timestamp format. + +This format is designed to simplify working with timestamps across +many different timezones by keeping the timestamp format itself in +UTC (and indicating this with a dot character), but appending the +local offset. + +This is implemented as a new format because the timestamp needs to be +rendered both as UTC and including the offset, an implementation using +a strftime formatting string is not sufficient. +--- + Documentation/rev-list-options.txt | 3 +++ + builtin/blame.c | 3 +++ + date.c | 17 +++++++++++++++++ + date.h | 3 ++- + t/t0006-date.sh | 2 ++ + 5 files changed, 27 insertions(+), 1 deletion(-) + +diff --git a/Documentation/rev-list-options.txt b/Documentation/rev-list-options.txt +index fd4f4e26c9..1f7ab97865 100644 +--- a/Documentation/rev-list-options.txt ++++ b/Documentation/rev-list-options.txt +@@ -1054,6 +1054,9 @@ omitted. + 1970). As with `--raw`, this is always in UTC and therefore `-local` + has no effect. + ++`--date=dottime` shows the date in dottime format (rendered as UTC, ++but suffixed with the local timezone offset if given) ++ + `--date=format:...` feeds the format `...` to your system `strftime`, + except for %s, %z, and %Z, which are handled internally. + Use `--date=format:%c` to show the date in your system locale's +diff --git a/builtin/blame.c b/builtin/blame.c +index 8d15b68afc..e0cdf418f5 100644 +--- a/builtin/blame.c ++++ b/builtin/blame.c +@@ -1009,6 +1009,9 @@ int cmd_blame(int argc, const char **argv, const char *prefix) + case DATE_STRFTIME: + blame_date_width = strlen(show_date(0, 0, &blame_date_mode)) + 1; /* add the null */ + break; ++ case DATE_DOTTIME: ++ blame_date_width = sizeof("2006-10-19T15·00-0700"); ++ break; + } + blame_date_width -= 1; /* strip the null */ + +diff --git a/date.c b/date.c +index 68a260c214..1485e3808f 100644 +--- a/date.c ++++ b/date.c +@@ -347,6 +347,21 @@ const char *show_date(timestamp_t time, int tz, const struct date_mode *mode) + tm->tm_mday, + tm->tm_hour, tm->tm_min, tm->tm_sec, + sign, tz / 100, tz % 100); ++ } else if (mode->type == DATE_DOTTIME) { ++ char sign = (tz >= 0) ? '+' : '-'; ++ tz = abs(tz); ++ ++ // Time is converted again without the timezone as the ++ // dottime format includes the zone only in offset ++ // position. ++ time_t t = gm_time_t(time, 0); ++ gmtime_r(&t, tm); ++ strbuf_addf(&timebuf, "%04d-%02d-%02dT%02d·%02d%c%02d%02d", ++ tm->tm_year + 1900, ++ tm->tm_mon + 1, ++ tm->tm_mday, ++ tm->tm_hour, tm->tm_min, ++ sign, tz / 100, tz % 100); + } else if (mode->type == DATE_RFC2822) + strbuf_addf(&timebuf, "%.3s, %d %.3s %d %02d:%02d:%02d %+05d", + weekday_names[tm->tm_wday], tm->tm_mday, +@@ -955,6 +970,8 @@ static enum date_mode_type parse_date_type(const char *format, const char **end) + return DATE_UNIX; + if (skip_prefix(format, "format", end)) + return DATE_STRFTIME; ++ if (skip_prefix(format, "dottime", end)) ++ return DATE_DOTTIME; + /* + * Please update $__git_log_date_formats in + * git-completion.bash when you add new formats. +diff --git a/date.h b/date.h +index 5d4eaba0a9..ff8fdffdbf 100644 +--- a/date.h ++++ b/date.h +@@ -17,7 +17,8 @@ enum date_mode_type { + DATE_RFC2822, + DATE_STRFTIME, + DATE_RAW, +- DATE_UNIX ++ DATE_UNIX, ++ DATE_DOTTIME + }; + + struct date_mode { +diff --git a/t/t0006-date.sh b/t/t0006-date.sh +index 2490162071..7ce4fe1927 100755 +--- a/t/t0006-date.sh ++++ b/t/t0006-date.sh +@@ -51,9 +51,11 @@ check_show short "$TIME" '2016-06-15' + check_show default "$TIME" 'Wed Jun 15 16:13:20 2016 +0200' + check_show raw "$TIME" '1466000000 +0200' + check_show unix "$TIME" '1466000000' ++check_show dottime "$TIME" '2016-06-15T14·13+0200' + check_show iso-local "$TIME" '2016-06-15 14:13:20 +0000' + check_show raw-local "$TIME" '1466000000 +0000' + check_show unix-local "$TIME" '1466000000' ++check_show dottime-local "$TIME" '2016-06-15T14·13+0000' + + check_show 'format:%z' "$TIME" '+0200' + check_show 'format-local:%z' "$TIME" '+0000' +-- +2.35.3 + diff --git a/third_party/git/default.nix b/third_party/git/default.nix new file mode 100644 index 0000000000..eed07b5616 --- /dev/null +++ b/third_party/git/default.nix @@ -0,0 +1,9 @@ +# git with custom patches. This is also used by cgit via +# `pkgs.srcOnly`. +{ pkgs, ... }: + +pkgs.git.overrideAttrs (old: { + patches = (old.patches or [ ]) ++ [ + ./0001-feat-third_party-git-date-add-dottime-format.patch + ]; +}) diff --git a/third_party/gitignoreSource/default.nix b/third_party/gitignoreSource/default.nix new file mode 100644 index 0000000000..150de7c990 --- /dev/null +++ b/third_party/gitignoreSource/default.nix @@ -0,0 +1,21 @@ +{ pkgs, ... }: + +let + gitignoreNix = import + (pkgs.fetchFromGitHub { + owner = "hercules-ci"; + repo = "gitignore"; + rev = "f9e996052b5af4032fe6150bba4a6fe4f7b9d698"; + sha256 = "0jrh5ghisaqdd0vldbywags20m2cxpkbbk5jjjmwaw0gr8nhsafv"; + }) + { inherit (pkgs) lib; }; + +in +{ + __functor = _: gitignoreNix.gitignoreSource; + + # expose extra functions here + inherit (gitignoreNix) + gitignoreFilter + ; +} diff --git a/third_party/gopkgs/cloud.google.com/go/default.nix b/third_party/gopkgs/cloud.google.com/go/default.nix new file mode 100644 index 0000000000..015d3e6308 --- /dev/null +++ b/third_party/gopkgs/cloud.google.com/go/default.nix @@ -0,0 +1,11 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "cloud.google.com/go"; + + src = pkgs.fetchgit { + url = "https://code.googlesource.com/gocloud"; + rev = "4f03f8e4ba168c636e1c218da7ab41a1c8c0d8cf"; + hash = "sha256:1cgr8f9349r4ymp2k0x49lby47jgi40bblvl1dk6i99ij6faj93d"; + }; +} diff --git a/third_party/gopkgs/github.com/cenkalti/backoff/default.nix b/third_party/gopkgs/github.com/cenkalti/backoff/default.nix new file mode 100644 index 0000000000..c0e0335de7 --- /dev/null +++ b/third_party/gopkgs/github.com/cenkalti/backoff/default.nix @@ -0,0 +1,12 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/cenkalti/backoff/v4"; + + src = pkgs.fetchFromGitHub { + owner = "cenkalti"; + repo = "backoff"; + rev = "18fe4ce5a8550e0d0919b680ad3c080a5455bddf"; + sha256 = "083617p066p77ik0js8wwgb5qzabgvl8wqpkjb8s9alpyqsq2mpg"; + }; +} diff --git a/third_party/gopkgs/github.com/charmbracelet/bubbles/default.nix b/third_party/gopkgs/github.com/charmbracelet/bubbles/default.nix new file mode 100644 index 0000000000..e041edd4b6 --- /dev/null +++ b/third_party/gopkgs/github.com/charmbracelet/bubbles/default.nix @@ -0,0 +1,16 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/charmbracelet/bubbles"; + src = pkgs.fetchFromGitHub { + owner = "charmbracelet"; + repo = "bubbles"; + # unreleased version required by bubbletea + rev = "v0.7.6"; + sha256 = "1gd4k4f2mj2dnqcbpdrh9plziz0l29ls6mgyy4mfdcdfijfyd30n"; + }; + + deps = with depot.third_party; [ + gopkgs."github.com".charmbracelet.bubbletea + ]; +} diff --git a/third_party/gopkgs/github.com/charmbracelet/bubbletea/default.nix b/third_party/gopkgs/github.com/charmbracelet/bubbletea/default.nix new file mode 100644 index 0000000000..8dc25bd918 --- /dev/null +++ b/third_party/gopkgs/github.com/charmbracelet/bubbletea/default.nix @@ -0,0 +1,30 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/charmbracelet/bubbletea"; + src = + let + gitSrc = pkgs.fetchFromGitHub { + owner = "charmbracelet"; + repo = "bubbletea"; + rev = "v0.13.1"; + sha256 = "0yf2fjkvx8ym9n6f3qp2z7sxs0qsfpj148sfvbrp38k67s3h20cs"; + }; + # The examples/ directory is fairly extensive, + # but it also adds most of the dependencies. + in + pkgs.runCommand gitSrc.name { } '' + mkdir -p $out + ln -s "${gitSrc}"/* $out + rm -r $out/examples + rm -r $out/tutorials + ''; + deps = with depot.third_party; [ + gopkgs."github.com".containerd.console + gopkgs."github.com".mattn.go-isatty + gopkgs."github.com".muesli.reflow.truncate + gopkgs."github.com".muesli.termenv + gopkgs."golang.org".x.sys.unix + gopkgs."golang.org".x.crypto.ssh.terminal + ]; +} diff --git a/third_party/gopkgs/github.com/charmbracelet/lipgloss/default.nix b/third_party/gopkgs/github.com/charmbracelet/lipgloss/default.nix new file mode 100644 index 0000000000..d10332a1d5 --- /dev/null +++ b/third_party/gopkgs/github.com/charmbracelet/lipgloss/default.nix @@ -0,0 +1,21 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/charmbracelet/lipgloss"; + src = pkgs.fetchFromGitHub { + owner = "charmbracelet"; + repo = "lipgloss"; + # unreleased version required by bubbletea + rev = "v0.1.0"; + sha256 = "1chhs492rsq7i4mr6qpjv3d89rvsd23ri6psnmil3ah6i286vl06"; + }; + + deps = with depot.third_party; [ + # gopkgs."github.com".charmbracelet.bubbletea + gopkgs."github.com".lucasb-eyer.go-colorful + gopkgs."github.com".muesli.reflow.ansi + gopkgs."github.com".muesli.reflow.truncate + gopkgs."github.com".muesli.reflow.wordwrap + gopkgs."github.com".muesli.termenv + ]; +} diff --git a/third_party/gopkgs/github.com/containerd/console/default.nix b/third_party/gopkgs/github.com/containerd/console/default.nix new file mode 100644 index 0000000000..3f451019e0 --- /dev/null +++ b/third_party/gopkgs/github.com/containerd/console/default.nix @@ -0,0 +1,15 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/containerd/console"; + src = pkgs.fetchFromGitHub { + owner = "containerd"; + repo = "console"; + rev = "v1.0.1"; + sha256 = "0s837wj6h80fykk2pdmaji75rw9c3863by0gh0cq51hh0lgyjpvg"; + }; + + deps = with depot.third_party; [ + gopkgs."golang.org".x.sys.unix + ]; +} diff --git a/third_party/gopkgs/github.com/davecgh/go-spew/default.nix b/third_party/gopkgs/github.com/davecgh/go-spew/default.nix new file mode 100644 index 0000000000..1395f3dce6 --- /dev/null +++ b/third_party/gopkgs/github.com/davecgh/go-spew/default.nix @@ -0,0 +1,11 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/davecgh/go-spew"; + src = pkgs.fetchFromGitHub { + owner = "davecgh"; + repo = "go-spew"; + rev = "8991bc29aa16c548c550c7ff78260e27b9ab7c73"; + sha256 = "0hka6hmyvp701adzag2g26cxdj47g21x6jz4sc6jjz1mn59d474y"; + }; +} diff --git a/third_party/gopkgs/github.com/emirpasic/gods/default.nix b/third_party/gopkgs/github.com/emirpasic/gods/default.nix new file mode 100644 index 0000000000..a858660f43 --- /dev/null +++ b/third_party/gopkgs/github.com/emirpasic/gods/default.nix @@ -0,0 +1,12 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/emirpasic/gods"; + + src = pkgs.fetchFromGitHub { + owner = "emirpasic"; + repo = "gods"; + rev = "4e23915b9a82f35f320a68a395a7a5045c826932"; + sha256 = "00f8ch1rccakc62f9nj97hapvnx84z7wbcdmbmz7p802b9mxk5nl"; + }; +} diff --git a/third_party/gopkgs/github.com/golang/glog/default.nix b/third_party/gopkgs/github.com/golang/glog/default.nix new file mode 100644 index 0000000000..c8426f2b1a --- /dev/null +++ b/third_party/gopkgs/github.com/golang/glog/default.nix @@ -0,0 +1,11 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/golang/glog"; + src = pkgs.fetchFromGitHub { + owner = "golang"; + repo = "glog"; + rev = "23def4e6c14b4da8ac2ed8007337bc5eb5007998"; + sha256 = "0jb2834rw5sykfr937fxi8hxi2zy80sj2bdn9b3jb4b26ksqng30"; + }; +} diff --git a/third_party/gopkgs/github.com/golang/groupcache/default.nix b/third_party/gopkgs/github.com/golang/groupcache/default.nix new file mode 100644 index 0000000000..c2fc341fea --- /dev/null +++ b/third_party/gopkgs/github.com/golang/groupcache/default.nix @@ -0,0 +1,15 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/golang/groupcache"; + + src = pkgs.fetchgit { + url = "https://github.com/golang/groupcache"; + rev = "611e8accdfc92c4187d399e95ce826046d4c8d73"; + hash = "sha256:0ydaq1xn03h2arfdri0vcv0df19pk8dvq4ly5hm1kv18yjfv1v13"; + }; + + deps = with depot.third_party; [ + gopkgs."github.com".golang.protobuf.proto + ]; +} diff --git a/third_party/gopkgs/github.com/golang/protobuf/default.nix b/third_party/gopkgs/github.com/golang/protobuf/default.nix new file mode 100644 index 0000000000..119eafb42c --- /dev/null +++ b/third_party/gopkgs/github.com/golang/protobuf/default.nix @@ -0,0 +1,11 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/golang/protobuf"; + + src = pkgs.fetchgit { + url = "https://github.com/golang/protobuf"; + rev = "ed6926b37a637426117ccab59282c3839528a700"; + hash = "sha256:0fynqrim022x9xi2bivkw19npbz4316v4yr7mb677s9s36z4dc4h"; + }; +} diff --git a/third_party/gopkgs/github.com/google/uuid/default.nix b/third_party/gopkgs/github.com/google/uuid/default.nix new file mode 100644 index 0000000000..191863bf0e --- /dev/null +++ b/third_party/gopkgs/github.com/google/uuid/default.nix @@ -0,0 +1,12 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/google/uuid"; + + src = pkgs.fetchFromGitHub { + owner = "google"; + repo = "uuid"; + rev = "c2e93f3ae59f2904160ceaab466009f965df46d6"; + sha256 = "0zw8fvl6jqg0fmv6kmvhss0g4gkrbvgyvl2zgy5wdbdlgp4fja0h"; + }; +} diff --git a/third_party/gopkgs/github.com/googleapis/gax-go/default.nix b/third_party/gopkgs/github.com/googleapis/gax-go/default.nix new file mode 100644 index 0000000000..63c6f4b1d7 --- /dev/null +++ b/third_party/gopkgs/github.com/googleapis/gax-go/default.nix @@ -0,0 +1,19 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/googleapis/gax-go"; + + src = pkgs.fetchFromGitHub { + owner = "googleapis"; + repo = "gax-go"; + rev = "b443e5a67ec8eeac76f5f384004931878cab24b3"; + sha256 = "075s8b76l14c9vlchly38hsf28bnr7vzq9q57g2kg1025h004lzw"; + }; + + deps = with depot.third_party; [ + gopkgs."golang.org".x.net.trace.gopkg + gopkgs."google.golang.org".grpc.gopkg + gopkgs."google.golang.org".grpc.codes.gopkg + gopkgs."google.golang.org".grpc.status.gopkg + ]; +} diff --git a/third_party/gopkgs/github.com/hashicorp/golang-lru/default.nix b/third_party/gopkgs/github.com/hashicorp/golang-lru/default.nix new file mode 100644 index 0000000000..8d540877d5 --- /dev/null +++ b/third_party/gopkgs/github.com/hashicorp/golang-lru/default.nix @@ -0,0 +1,16 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/hashicorp/golang-lru"; + + src = pkgs.fetchgit { + url = "https://github.com/hashicorp/golang-lru"; + rev = "7f827b33c0f158ec5dfbba01bb0b14a4541fd81d"; + hash = "sha256:1p2igd58xkm8yaj2c2wxiplkf2hj6kxwrg6ss7mx61s5rd71v5xb"; + }; + + deps = with depot.third_party; [ + gopkgs."golang.org".x.net.context.ctxhttp + gopkgs."cloud.google.com".go.compute.metadata + ]; +} diff --git a/third_party/gopkgs/github.com/jbenet/go-context/default.nix b/third_party/gopkgs/github.com/jbenet/go-context/default.nix new file mode 100644 index 0000000000..401fc6eb40 --- /dev/null +++ b/third_party/gopkgs/github.com/jbenet/go-context/default.nix @@ -0,0 +1,16 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/jbenet/go-context"; + + src = pkgs.fetchFromGitHub { + owner = "jbenet"; + repo = "go-context"; + rev = "d14ea06fba99483203c19d92cfcd13ebe73135f4"; + sha256 = "0q91f5549n81w3z5927n4a1mdh220bdmgl42zi3h992dcc4ls0sl"; + }; + + deps = with depot.third_party; [ + gopkgs."golang.org".x.net.context + ]; +} diff --git a/third_party/gopkgs/github.com/kevinburke/ssh_config/default.nix b/third_party/gopkgs/github.com/kevinburke/ssh_config/default.nix new file mode 100644 index 0000000000..6b4e8f5275 --- /dev/null +++ b/third_party/gopkgs/github.com/kevinburke/ssh_config/default.nix @@ -0,0 +1,12 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/kevinburke/ssh_config"; + + src = pkgs.fetchFromGitHub { + owner = "kevinburke"; + repo = "ssh_config"; + rev = "01f96b0aa0cdcaa93f9495f89bbc6cb5a992ce6e"; + sha256 = "1bxfjkjl3ibzdkwyvgdwawmd0skz30ah1ha10rg6fkxvj7lgg4jz"; + }; +} diff --git a/third_party/gopkgs/github.com/lucasb-eyer/go-colorful/default.nix b/third_party/gopkgs/github.com/lucasb-eyer/go-colorful/default.nix new file mode 100644 index 0000000000..decb7f3db9 --- /dev/null +++ b/third_party/gopkgs/github.com/lucasb-eyer/go-colorful/default.nix @@ -0,0 +1,12 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/lucasb-eyer/go-colorful"; + src = pkgs.fetchFromGitHub { + owner = "lucasb-eyer"; + repo = "go-colorful"; + # unreleased version required by bubbletea + rev = "v1.2.0"; + sha256 = "08c3fkf27r16izjjd4w94xd1z7w1r4mdalbl53ms2ka2j465s3qs"; + }; +} diff --git a/third_party/gopkgs/github.com/mattn/go-isatty/default.nix b/third_party/gopkgs/github.com/mattn/go-isatty/default.nix new file mode 100644 index 0000000000..6ba12afff7 --- /dev/null +++ b/third_party/gopkgs/github.com/mattn/go-isatty/default.nix @@ -0,0 +1,15 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/mattn/go-isatty"; + src = pkgs.fetchFromGitHub { + owner = "mattn"; + repo = "go-isatty"; + rev = "v0.0.12"; + sha256 = "1dfsh27d52wmz0nmmzm2382pfrs2fcijvh6cgir7jbb4pnigr5w4"; + }; + + deps = with depot.third_party; [ + gopkgs."golang.org".x.sys.unix + ]; +} diff --git a/third_party/gopkgs/github.com/mattn/go-runewidth/default.nix b/third_party/gopkgs/github.com/mattn/go-runewidth/default.nix new file mode 100644 index 0000000000..3186a06629 --- /dev/null +++ b/third_party/gopkgs/github.com/mattn/go-runewidth/default.nix @@ -0,0 +1,15 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/mattn/go-runewidth"; + src = pkgs.fetchFromGitHub { + owner = "mattn"; + repo = "go-runewidth"; + rev = "v0.0.10"; + sha256 = "0jh9552ppqvkdfni7x623n0x5mbiaqqhjhmr0zkh28x56k4ysii4"; + }; + + deps = with depot.third_party; [ + gopkgs."github.com".rivo.uniseg + ]; +} diff --git a/third_party/gopkgs/github.com/mitchellh/go-homedir/default.nix b/third_party/gopkgs/github.com/mitchellh/go-homedir/default.nix new file mode 100644 index 0000000000..8c593eaae8 --- /dev/null +++ b/third_party/gopkgs/github.com/mitchellh/go-homedir/default.nix @@ -0,0 +1,12 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/mitchellh/go-homedir"; + + src = pkgs.fetchFromGitHub { + owner = "mitchellh"; + repo = "go-homedir"; + rev = "af06845cf3004701891bf4fdb884bfe4920b3727"; + sha256 = "0ydzkipf28hwj2bfxqmwlww47khyk6d152xax4bnyh60f4lq3nx1"; + }; +} diff --git a/third_party/gopkgs/github.com/muesli/reflow/default.nix b/third_party/gopkgs/github.com/muesli/reflow/default.nix new file mode 100644 index 0000000000..c7c50795c0 --- /dev/null +++ b/third_party/gopkgs/github.com/muesli/reflow/default.nix @@ -0,0 +1,16 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/muesli/reflow"; + src = pkgs.fetchFromGitHub { + owner = "muesli"; + repo = "reflow"; + # unreleased version required by bubbletea + rev = "9e1d0d53df68baf262851201166872afafd04e5d"; + sha256 = "08bmkqdn7sb5laqc1mvgk4xj31f600n1y04s1ifppjvszbcsxhid"; + }; + + deps = with depot.third_party; [ + gopkgs."github.com".mattn.go-runewidth + ]; +} diff --git a/third_party/gopkgs/github.com/muesli/termenv/default.nix b/third_party/gopkgs/github.com/muesli/termenv/default.nix new file mode 100644 index 0000000000..504d535954 --- /dev/null +++ b/third_party/gopkgs/github.com/muesli/termenv/default.nix @@ -0,0 +1,19 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/muesli/termenv"; + src = pkgs.fetchFromGitHub { + owner = "muesli"; + repo = "termenv"; + # unreleased version required by bubbletea + rev = "v0.8.1"; + sha256 = "0m24ljq1nq7z933fcvg99fw0fhxj9rb5ll4rlay7z2f2p59mrbdp"; + }; + + deps = with depot.third_party; [ + gopkgs."github.com".lucasb-eyer.go-colorful + gopkgs."github.com".mattn.go-isatty + gopkgs."github.com".mattn.go-runewidth + gopkgs."golang.org".x.sys.unix + ]; +} diff --git a/third_party/gopkgs/github.com/pkg/browser/default.nix b/third_party/gopkgs/github.com/pkg/browser/default.nix new file mode 100644 index 0000000000..4588c1b589 --- /dev/null +++ b/third_party/gopkgs/github.com/pkg/browser/default.nix @@ -0,0 +1,12 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/pkg/browser"; + + src = pkgs.fetchFromGitHub { + owner = "pkg"; + repo = "browser"; + rev = "0a3d74bf9ce488f035cf5bc36f753a711bc74334"; + sha256 = "0lv6kwvm31n79mh14a63zslaf4l9bspi2q0i8i9im4njfl42iv1c"; + }; +} diff --git a/third_party/gopkgs/github.com/rivo/uniseg/default.nix b/third_party/gopkgs/github.com/rivo/uniseg/default.nix new file mode 100644 index 0000000000..f37d70bbda --- /dev/null +++ b/third_party/gopkgs/github.com/rivo/uniseg/default.nix @@ -0,0 +1,14 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/rivo/uniseg"; + src = pkgs.fetchFromGitHub { + owner = "rivo"; + repo = "uniseg"; + rev = "v0.1.0"; + sha256 = "0flpc1px1l6b1lxzhdxi0mvpkkjchppvgxshxxnlmm40s76i9ww5"; + }; + + deps = with depot.third_party; [ + ]; +} diff --git a/third_party/gopkgs/github.com/sergi/go-diff/default.nix b/third_party/gopkgs/github.com/sergi/go-diff/default.nix new file mode 100644 index 0000000000..72fb96d475 --- /dev/null +++ b/third_party/gopkgs/github.com/sergi/go-diff/default.nix @@ -0,0 +1,12 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/sergi/go-diff"; + + src = pkgs.fetchFromGitHub { + owner = "sergi"; + repo = "go-diff"; + rev = "58c5cb1602ee9676b5d3590d782bedde80706fcc"; + sha256 = "0ir8ali2vx0j7pipmlfd6k8c973akyy2nmbjrf008fm800zcp7z2"; + }; +} diff --git a/third_party/gopkgs/github.com/src-d/gcfg/default.nix b/third_party/gopkgs/github.com/src-d/gcfg/default.nix new file mode 100644 index 0000000000..210ab1bc70 --- /dev/null +++ b/third_party/gopkgs/github.com/src-d/gcfg/default.nix @@ -0,0 +1,16 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/src-d/gcfg"; + + src = pkgs.fetchFromGitHub { + owner = "src-d"; + repo = "gcfg"; + rev = "1ac3a1ac202429a54835fe8408a92880156b489d"; + sha256 = "044j95skmyrwjw5fwjk6ka32rjgsg0ar0mfp9np19sh1acwv4x4r"; + }; + + deps = with depot.third_party; [ + gopkgs."gopkg.in".warnings + ]; +} diff --git a/third_party/gopkgs/github.com/xanzy/ssh-agent/default.nix b/third_party/gopkgs/github.com/xanzy/ssh-agent/default.nix new file mode 100644 index 0000000000..078592aa9d --- /dev/null +++ b/third_party/gopkgs/github.com/xanzy/ssh-agent/default.nix @@ -0,0 +1,16 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "github.com/xanzy/ssh-agent"; + + src = pkgs.fetchFromGitHub { + owner = "xanzy"; + repo = "ssh-agent"; + rev = "6a3e2ff9e7c564f36873c2e36413f634534f1c44"; + sha256 = "1chjlnv5d6svpymxgsr62d992m2xi6jb5lybjc5zn1h3hv1m01av"; + }; + + deps = with depot.third_party; [ + gopkgs."golang.org".x.crypto.ssh.agent + ]; +} diff --git a/third_party/gopkgs/go.opencensus.io/default.nix b/third_party/gopkgs/go.opencensus.io/default.nix new file mode 100644 index 0000000000..b1ee6da1fc --- /dev/null +++ b/third_party/gopkgs/go.opencensus.io/default.nix @@ -0,0 +1,17 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "go.opencensus.io"; + + src = pkgs.fetchFromGitHub { + owner = "census-instrumentation"; + repo = "opencensus-go"; + rev = "643eada29081047b355cfaa1ceb9bc307a10423c"; + sha256 = "1acmv2f5wz06abphk0yvb9igp2j5sn1v21dg1p8n109rwanwd5v4"; + }; + + deps = with depot.third_party; [ + gopkgs."github.com".hashicorp.golang-lru.simplelru + gopkgs."github.com".golang.groupcache.lru + ]; +} diff --git a/third_party/gopkgs/golang.org/x/crypto/default.nix b/third_party/gopkgs/golang.org/x/crypto/default.nix new file mode 100644 index 0000000000..41c3b4e726 --- /dev/null +++ b/third_party/gopkgs/golang.org/x/crypto/default.nix @@ -0,0 +1,15 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "golang.org/x/crypto"; + + src = pkgs.fetchgit { + url = "https://go.googlesource.com/crypto"; + rev = "e9b2fee46413994441b28dfca259d911d963dfed"; + hash = "sha256:18sz5426h320l9gdll9n43lzzxg2dmqv0s5fjy6sbvbkkpjs1m28"; + }; + + deps = with depot.third_party; [ + gopkgs."golang.org".x.sys.unix.gopkg + ]; +} diff --git a/third_party/gopkgs/golang.org/x/net/default.nix b/third_party/gopkgs/golang.org/x/net/default.nix new file mode 100644 index 0000000000..9a8fef6948 --- /dev/null +++ b/third_party/gopkgs/golang.org/x/net/default.nix @@ -0,0 +1,17 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "golang.org/x/net"; + + src = pkgs.fetchgit { + url = "https://go.googlesource.com/net"; + rev = "c0dbc17a35534bf2e581d7a942408dc936316da4"; + hash = "sha256:1f1xqh2cvr629fkg9n9k347vf6g91jkrsmgmy8hlqdrq163blb54"; + }; + + deps = with depot.third_party; [ + gopkgs."golang.org".x.text.secure.bidirule.gopkg + gopkgs."golang.org".x.text.unicode.bidi.gopkg + gopkgs."golang.org".x.text.unicode.norm.gopkg + ]; +} diff --git a/third_party/gopkgs/golang.org/x/oauth2/default.nix b/third_party/gopkgs/golang.org/x/oauth2/default.nix new file mode 100644 index 0000000000..60864ffe4a --- /dev/null +++ b/third_party/gopkgs/golang.org/x/oauth2/default.nix @@ -0,0 +1,16 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "golang.org/x/oauth2"; + + src = pkgs.fetchgit { + url = "https://go.googlesource.com/oauth2"; + rev = "858c2ad4c8b6c5d10852cb89079f6ca1c7309787"; + hash = "sha256:1dc7n8ddph8w6q0i3cwlgvjwpf2wlkx407va1ydnazasi1j5ixrw"; + }; + + deps = with depot.third_party; [ + gopkgs."golang.org".x.net.context.ctxhttp + gopkgs."cloud.google.com".go.compute.metadata + ]; +} diff --git a/third_party/gopkgs/golang.org/x/sys/default.nix b/third_party/gopkgs/golang.org/x/sys/default.nix new file mode 100644 index 0000000000..8da07693ce --- /dev/null +++ b/third_party/gopkgs/golang.org/x/sys/default.nix @@ -0,0 +1,11 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "golang.org/x/sys"; + + src = pkgs.fetchgit { + url = "https://go.googlesource.com/sys"; + rev = "ac6580df4449443a05718fd7858c1f91ad5f8d20"; + hash = "sha256:14gvx65w5lddi20s4wypbbvbg9ni3m8777jhp9nqxhixc61k3dyi"; + }; +} diff --git a/third_party/gopkgs/golang.org/x/text/default.nix b/third_party/gopkgs/golang.org/x/text/default.nix new file mode 100644 index 0000000000..f5a900b958 --- /dev/null +++ b/third_party/gopkgs/golang.org/x/text/default.nix @@ -0,0 +1,11 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "golang.org/x/text"; + + src = pkgs.fetchgit { + url = "https://go.googlesource.com/text"; + rev = "cbf43d21aaebfdfeb81d91a5f444d13a3046e686"; + hash = "sha256:1h6z2x4ijzd1126zk3lf8f3bp98j1irs7xg6p8nwpymkqkw5laq8"; + }; +} diff --git a/third_party/gopkgs/golang.org/x/time/default.nix b/third_party/gopkgs/golang.org/x/time/default.nix new file mode 100644 index 0000000000..1c03a8f0a9 --- /dev/null +++ b/third_party/gopkgs/golang.org/x/time/default.nix @@ -0,0 +1,11 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "golang.org/x/time"; + + src = pkgs.fetchgit { + url = "https://go.googlesource.com/time"; + rev = "555d28b269f0569763d25dbe1a237ae74c6bcc82"; + hash = "sha256:1rhl4lyz030kwfsg63yk83yd3ivryv1afmzdz9sxbhcj84ym6h4r"; + }; +} diff --git a/third_party/gopkgs/google.golang.org/api/default.nix b/third_party/gopkgs/google.golang.org/api/default.nix new file mode 100644 index 0000000000..490d3a9d2b --- /dev/null +++ b/third_party/gopkgs/google.golang.org/api/default.nix @@ -0,0 +1,22 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "google.golang.org/api"; + + src = pkgs.fetchgit { + url = "https://code.googlesource.com/google-api-go-client"; + rev = "8b4e46d953bd748a9ff098644a42389b3d8dab41"; + hash = "sha256:1vffav53qkksrhdqnp8013v90ks6d7jra0vh3sbybg0v0bka7n3p"; + }; + + deps = with depot.third_party; [ + gopkgs."github.com".googleapis.gax-go.v2 + gopkgs."golang.org".x.oauth2.google + gopkgs."golang.org".x.oauth2 + gopkgs."google.golang.org".grpc + gopkgs."google.golang.org".grpc.naming + gopkgs."go.opencensus.io".plugin.ochttp + gopkgs."go.opencensus.io".trace + gopkgs."go.opencensus.io".trace.propagation + ]; +} diff --git a/third_party/gopkgs/google.golang.org/genproto/default.nix b/third_party/gopkgs/google.golang.org/genproto/default.nix new file mode 100644 index 0000000000..cba54e5890 --- /dev/null +++ b/third_party/gopkgs/google.golang.org/genproto/default.nix @@ -0,0 +1,16 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "google.golang.org/genproto"; + + src = pkgs.fetchgit { + url = "https://github.com/google/go-genproto"; + rev = "0243a4be9c8f1264d238fdc2895620b4d9baf9e1"; + hash = "sha256:071672lk0pzns98ncbqk6np7l9flwh84hjjibhhm2s1fi941m6q3"; + }; + + deps = with depot.third_party; [ + gopkgs."github.com".golang.protobuf.proto.gopkg + gopkgs."github.com".golang.protobuf.ptypes.any.gopkg + ]; +} diff --git a/third_party/gopkgs/google.golang.org/grpc/default.nix b/third_party/gopkgs/google.golang.org/grpc/default.nix new file mode 100644 index 0000000000..522a27d602 --- /dev/null +++ b/third_party/gopkgs/google.golang.org/grpc/default.nix @@ -0,0 +1,23 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "google.golang.org/grpc"; + + src = pkgs.fetchgit { + url = "https://github.com/grpc/grpc-go"; + rev = "085c980048876e2735d4aba8f0d5bca4d7acaaa5"; + hash = "sha256:1vl089pv8qgxkbdg10kyd7203psn35wwjzxxbvi22628faqcpg61"; + }; + + deps = with depot.third_party; [ + gopkgs."golang.org".x.net.trace + gopkgs."golang.org".x.net.http2 + gopkgs."golang.org".x.net.http2.hpack + gopkgs."golang.org".x.sys.unix + gopkgs."github.com".golang.protobuf.proto + gopkgs."github.com".golang.protobuf.ptypes + gopkgs."github.com".golang.protobuf.ptypes.duration + gopkgs."github.com".golang.protobuf.ptypes.timestamp + gopkgs."google.golang.org".genproto.googleapis.rpc.status + ]; +} diff --git a/third_party/gopkgs/googlemaps.github.io/maps.nix b/third_party/gopkgs/googlemaps.github.io/maps.nix new file mode 100644 index 0000000000..4d29cc2f89 --- /dev/null +++ b/third_party/gopkgs/googlemaps.github.io/maps.nix @@ -0,0 +1,17 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "googlemaps.github.io/maps"; + + src = pkgs.fetchFromGitHub { + owner = "googlemaps"; + repo = "google-maps-services-go"; + rev = "a46d9fca56ac82caa79408b2417ea93a75e3b986"; + sha256 = "1zpl85yd3m417060isdlhxzakqkf4f59jgpz3kcjp2i0mkrskkjs"; + }; + + deps = with depot.third_party; [ + gopkgs."github.com".google.uuid + gopkgs."golang.org".x.time.rate + ]; +} diff --git a/third_party/gopkgs/gopkg.in/irc.v3/default.nix b/third_party/gopkgs/gopkg.in/irc.v3/default.nix new file mode 100644 index 0000000000..7bfe550023 --- /dev/null +++ b/third_party/gopkgs/gopkg.in/irc.v3/default.nix @@ -0,0 +1,12 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "gopkg.in/irc.v3"; + + src = pkgs.fetchFromGitHub { + owner = "go-irc"; + repo = "irc"; + rev = "21a5301d6035ea204b2a7bb522a7b4598e5f6b28"; + sha256 = "1pi5y73pr4prhw5bvmp4babiw02nndizgmpksdgrrg28l9f2wm0n"; + }; +} diff --git a/third_party/gopkgs/gopkg.in/src-d/go-billy/default.nix b/third_party/gopkgs/gopkg.in/src-d/go-billy/default.nix new file mode 100644 index 0000000000..b2773d85d5 --- /dev/null +++ b/third_party/gopkgs/gopkg.in/src-d/go-billy/default.nix @@ -0,0 +1,16 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "gopkg.in/src-d/go-billy.v4"; + + src = pkgs.fetchFromGitHub { + owner = "src-d"; + repo = "go-billy"; + rev = "fd409ff12f33d0d60af0ce0abeb8d93df360af49"; + sha256 = "1j0pl6ggzmd2lrqj71vmsnl6cqm43145h7yg6sy3j5n7hhd592qv"; + }; + + deps = with depot.third_party; [ + gopkgs."golang.org".x.sys.unix + ]; +} diff --git a/third_party/gopkgs/gopkg.in/src-d/go-git/default.nix b/third_party/gopkgs/gopkg.in/src-d/go-git/default.nix new file mode 100644 index 0000000000..ce5fe1d240 --- /dev/null +++ b/third_party/gopkgs/gopkg.in/src-d/go-git/default.nix @@ -0,0 +1,31 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + # .v4 is used throughout the codebase and I can't be bothered to do + # anything else about it other than using that package path here. + path = "gopkg.in/src-d/go-git.v4"; + + src = pkgs.fetchFromGitHub { + owner = "src-d"; + repo = "go-git"; + rev = "1a7db85bca7027d90afdb5ce711622aaac9feaed"; + sha256 = "08jl4ljrzzil7c3qcl2y1859nhpgw9ixxy1g40ff7kmq989yhs6v"; + }; + + deps = with depot.third_party; [ + gopkgs."github.com".emirpasic.gods.trees.binaryheap + gopkgs."github.com".jbenet.go-context.io + gopkgs."github.com".kevinburke.ssh_config + gopkgs."github.com".mitchellh.go-homedir + gopkgs."github.com".sergi.go-diff.diffmatchpatch + gopkgs."github.com".src-d.gcfg + gopkgs."github.com".xanzy.ssh-agent + gopkgs."golang.org".x.crypto.openpgp + gopkgs."golang.org".x.crypto.ssh + gopkgs."golang.org".x.crypto.ssh.knownhosts + gopkgs."golang.org".x.net.proxy + gopkgs."gopkg.in".src-d.go-billy + gopkgs."gopkg.in".src-d.go-billy.osfs + gopkgs."gopkg.in".src-d.go-billy.util + ]; +} diff --git a/third_party/gopkgs/gopkg.in/warnings/default.nix b/third_party/gopkgs/gopkg.in/warnings/default.nix new file mode 100644 index 0000000000..1b4659d3d8 --- /dev/null +++ b/third_party/gopkgs/gopkg.in/warnings/default.nix @@ -0,0 +1,12 @@ +{ depot, pkgs, ... }: + +depot.nix.buildGo.external { + path = "gopkg.in/warnings.v0"; + + src = pkgs.fetchFromGitHub { + owner = "go-warnings"; + repo = "warnings"; + rev = "27b9fabbdaf131d2169ec3ff7db8ffc4d839635e"; + sha256 = "1y276jd9gwvjriz8yd98k3srgbnmbja8f7f7m6lvr0h5sbq3g3w9"; + }; +} diff --git a/third_party/hii/OWNERS b/third_party/hii/OWNERS new file mode 100644 index 0000000000..a640227914 --- /dev/null +++ b/third_party/hii/OWNERS @@ -0,0 +1 @@ +Profpatsch diff --git a/third_party/irccat/default.nix b/third_party/irccat/default.nix new file mode 100644 index 0000000000..c5d7a5f6df --- /dev/null +++ b/third_party/irccat/default.nix @@ -0,0 +1,16 @@ +# https://github.com/irccloud/irccat +{ lib, pkgs, ... }: + +pkgs.buildGoModule rec { + pname = "irccat"; + version = "20201108"; + meta.license = lib.licenses.gpl3; + vendorHash = "sha256:06a985y4alw1rsghgmhfyczns6klz7bbkfn5mnqc9fdfclgg4s3r"; + + src = pkgs.fetchFromGitHub { + owner = "irccloud"; + repo = "irccat"; + rev = "17451e7e267f099e9614ec945541b624520f607e"; + sha256 = "0l99mycxymyslwi8mmyfdcqa8pdp79wcyb04s5j5y4grmlsxw1wx"; + }; +} diff --git a/third_party/josh/default.nix b/third_party/josh/default.nix new file mode 100644 index 0000000000..9750780d1f --- /dev/null +++ b/third_party/josh/default.nix @@ -0,0 +1,49 @@ +# https://github.com/josh-project/josh +{ depot, pkgs, ... }: + +let + # TODO(sterni): switch to pkgs.josh as soon as that commit is released + rev = "1586eab06284ce668779c87f00a1fb5fa9763be0"; + src = pkgs.fetchFromGitHub { + owner = "josh-project"; + repo = "josh"; + inherit rev; + hash = "sha256-94QrHcVHiEMCpBZJ5sghwtVNLNm4gdG8X85OetoGRD0="; + }; + + + naersk = pkgs.callPackage depot.third_party.sources.naersk { + inherit (pkgs) rustc cargo; + }; + version = "git-${builtins.substring 0 8 rev}"; +in +naersk.buildPackage { + pname = "josh"; + inherit src version; + JOSH_VERSION = version; + + buildInputs = with pkgs; [ + libgit2 + openssl + pkg-config + ]; + + dontStrip = true; + cargoBuildOptions = x: x ++ [ + "-p" + "josh-filter" + "-p" + "josh-proxy" + ]; + + overrideMain = x: { + preBuild = x.preBuild or "" + '' + echo 'debug = true' >> Cargo.toml + ''; + + nativeBuildInputs = (x.nativeBuildInputs or [ ]) ++ [ pkgs.makeWrapper ]; + postInstall = '' + wrapProgram $out/bin/josh-proxy --prefix PATH : "${pkgs.git}/bin" + ''; + }; +} diff --git a/third_party/kernelPatches/trx40_usb_audio/default.nix b/third_party/kernelPatches/trx40_usb_audio/default.nix new file mode 100644 index 0000000000..f753878f7c --- /dev/null +++ b/third_party/kernelPatches/trx40_usb_audio/default.nix @@ -0,0 +1,9 @@ +# This patch adds the ASUS TRX40 Prime Pro Whatever Edition +# motherboard to the list of boards for which the USB Audio connector +# map has been fixed. +{ ... }: + +{ + name = "trx40_usb_audio"; + patch = ./trx40_usb_audio.patch; +} diff --git a/third_party/kernelPatches/trx40_usb_audio/trx40_usb_audio.patch b/third_party/kernelPatches/trx40_usb_audio/trx40_usb_audio.patch new file mode 100644 index 0000000000..d55b7bc362 --- /dev/null +++ b/third_party/kernelPatches/trx40_usb_audio/trx40_usb_audio.patch @@ -0,0 +1,16 @@ +diff --git a/sound/usb/mixer_maps.c b/sound/usb/mixer_maps.c +index 0260c750e156..5ee82872e31b 100644 +--- a/sound/usb/mixer_maps.c ++++ b/sound/usb/mixer_maps.c +@@ -539,6 +539,11 @@ static const struct usbmix_ctl_map usbmix_ctl_maps[] = { + .id = USB_ID(0x0b05, 0x1917), + .map = asus_rog_map, + }, ++ { /* ASUS TRX40 Prime */ ++ .id = USB_ID(0x0b05, 0x1918), ++ .map = trx40_mobo_map, ++ .connector_map = trx40_mobo_connector_map, ++ }, + { /* MSI TRX40 Creator */ + .id = USB_ID(0x0db0, 0x0d64), + .map = trx40_mobo_map, diff --git a/third_party/lisp/OWNERS b/third_party/lisp/OWNERS new file mode 100644 index 0000000000..6536baf505 --- /dev/null +++ b/third_party/lisp/OWNERS @@ -0,0 +1,2 @@ +eta +aspen diff --git a/third_party/lisp/alexandria.nix b/third_party/lisp/alexandria.nix new file mode 100644 index 0000000000..b522e2d142 --- /dev/null +++ b/third_party/lisp/alexandria.nix @@ -0,0 +1,28 @@ +# Alexandria is one of the foundational Common Lisp libraries that +# pretty much everything depends on. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.alexandria; +in depot.nix.buildLisp.library { + name = "alexandria"; + + srcs = map (f: src + ("/alexandria-1/" + f)) [ + "package.lisp" + "definitions.lisp" + "binding.lisp" + "strings.lisp" + "conditions.lisp" + "symbols.lisp" + "macros.lisp" + "functions.lisp" + "io.lisp" + "hash-tables.lisp" + "control-flow.lisp" + "lists.lisp" + "types.lisp" + "arrays.lisp" + "sequences.lisp" + "numbers.lisp" + "features.lisp" + ]; +} diff --git a/third_party/lisp/anaphora.nix b/third_party/lisp/anaphora.nix new file mode 100644 index 0000000000..c079943e67 --- /dev/null +++ b/third_party/lisp/anaphora.nix @@ -0,0 +1,13 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.anaphora; +in depot.nix.buildLisp.library { + name = "anaphora"; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "early.lisp" + "symbolic.lisp" + "anaphora.lisp" + ]; +} diff --git a/third_party/lisp/asdf-flv/.gitattributes b/third_party/lisp/asdf-flv/.gitattributes new file mode 100644 index 0000000000..2b45716e47 --- /dev/null +++ b/third_party/lisp/asdf-flv/.gitattributes @@ -0,0 +1,2 @@ +.gitignore export-ignore +.gitattributes export-ignore diff --git a/third_party/lisp/asdf-flv/.gitignore b/third_party/lisp/asdf-flv/.gitignore new file mode 100644 index 0000000000..bdf4ad2ae6 --- /dev/null +++ b/third_party/lisp/asdf-flv/.gitignore @@ -0,0 +1,3 @@ +sbcl-*/ +cmu-*/ +openmcl-*/ diff --git a/third_party/lisp/asdf-flv/Makefile b/third_party/lisp/asdf-flv/Makefile new file mode 100644 index 0000000000..b4c74feefe --- /dev/null +++ b/third_party/lisp/asdf-flv/Makefile @@ -0,0 +1,77 @@ +### Makefile --- Toplevel directory + +## Copyright (C) 2011, 2015 Didier Verna + +## Author: Didier Verna <didier@didierverna.net> + +## This file is part of ASDF-FLV. + +## Copying and distribution of this file, with or without modification, +## are permitted in any medium without royalty provided the copyright +## notice and this notice are preserved. This file is offered as-is, +## without any warranty. + + +### Commentary: + +## Contents management by FCM version 0.1. + + +### Code: + +PROJECT := asdf-flv +VERSION := 2.1 + +W3DIR := $(HOME)/www/software/lisp/$(PROJECT) + +DIST_NAME := $(PROJECT)-$(VERSION) +TARBALL := $(DIST_NAME).tar.gz +SIGNATURE := $(TARBALL).asc + + +all: + +clean: + -rm *~ + +distclean: clean + -rm *.tar.gz *.tar.gz.asc + +tag: + git tag -a -m 'Version $(VERSION)' 'version-$(VERSION)' + +tar: $(TARBALL) +gpg: $(SIGNATURE) +dist: tar gpg + +install-www: dist + -install -m 644 $(TARBALL) "$(W3DIR)/attic/" + -install -m 644 $(SIGNATURE) "$(W3DIR)/attic/" + echo "\ +<? lref (\"$(PROJECT)/attic/$(PROJECT)-$(VERSION).tar.gz\", \ + contents (\"Dernire version\", \"Latest version\")); ?> \ +| \ +<? lref (\"$(PROJECT)/attic/$(PROJECT)-$(VERSION).tar.gz.asc\", \ + contents (\"Signature GPG\", \"GPG Signature\")); ?>" \ + > "$(W3DIR)/latest.txt" + chmod 644 "$(W3DIR)/latest.txt" + cd "$(W3DIR)" \ + && ln -fs attic/$(TARBALL) latest.tar.gz \ + && ln -fs attic/$(SIGNATURE) latest.tar.gz.asc + +update-version: + perl -pi -e 's/:version ".*"/:version "$(VERSION)"/' \ + net.didierverna.$(PROJECT).asd + +$(TARBALL): + git archive --format=tar --prefix=$(DIST_NAME)/ \ + --worktree-attributes HEAD \ + | gzip -c > $@ + +$(SIGNATURE): $(TARBALL) + gpg -b -a $< + + +.PHONY: all clean distclean tag tar gpg dist install-www update-version + +### Makefile ends here diff --git a/third_party/lisp/asdf-flv/README.md b/third_party/lisp/asdf-flv/README.md new file mode 100644 index 0000000000..7ccdd18881 --- /dev/null +++ b/third_party/lisp/asdf-flv/README.md @@ -0,0 +1,7 @@ +ASDF-FLV provides support for file-local variables through ASDF. A file-local +variable behaves like `*PACKAGE*` and `*READTABLE*` with respect to `LOAD` and +`COMPILE-FILE`: a new dynamic binding is created before processing the file, +so that any modification to the variable essentially becomes file-local. + +In order to make one or several variables file-local, use the macros +`SET-FILE-LOCAL-VARIABLE(S)`. diff --git a/third_party/lisp/asdf-flv/asdf-flv.lisp b/third_party/lisp/asdf-flv/asdf-flv.lisp new file mode 100644 index 0000000000..76c6845b82 --- /dev/null +++ b/third_party/lisp/asdf-flv/asdf-flv.lisp @@ -0,0 +1,64 @@ +;;; asdf-flv.lisp --- Implementation + +;; Copyright (C) 2011, 2015 Didier Verna + +;; Author: Didier Verna <didier@didierverna.net> + +;; This file is part of ASDF-FLV. + +;; Copying and distribution of this file, with or without modification, +;; are permitted in any medium without royalty provided the copyright +;; notice and this notice are preserved. This file is offered as-is, +;; without any warranty. + + +;;; Commentary: + +;; Contents management by FCM version 0.1. + + +;;; Code: + +(in-package :net.didierverna.asdf-flv) + + +(defvar *file-local-variables* () + "List of file-local special variables.") + + +(defun make-variable-file-local (symbol) + "Make special variable named by SYMBOL have a file-local value." + (pushnew symbol *file-local-variables*)) + +(defmacro set-file-local-variable (symbol) + "Set special variable named by SYMBOL as file-local. +SYMBOL need not be quoted." + `(make-variable-file-local ',symbol)) + +(defun make-variables-file-local (&rest symbols) + "Make special variables named by SYMBOLS have a file-local value." + (dolist (symbol symbols) + (pushnew symbol *file-local-variables*))) + +(defmacro set-file-local-variables (&rest symbols) + "Set special variables named by SYMBOLS as file-local. +SYMBOLS need not be quoted." + `(make-variables-file-local ,@(mapcar (lambda (symbol) (list 'quote symbol)) + symbols))) + + +(defmethod asdf:perform :around + ((operation asdf:load-op) (file asdf:cl-source-file)) + "Establish new dynamic bindings for file-local variables." + (progv *file-local-variables* + (mapcar #'symbol-value *file-local-variables*) + (call-next-method))) + +(defmethod asdf:perform :around + ((operation asdf:compile-op) (file asdf:cl-source-file)) + "Establish new dynamic bindings for file-local variables." + (progv *file-local-variables* + (mapcar #'symbol-value *file-local-variables*) + (call-next-method))) + +;;; asdf-flv.lisp ends here diff --git a/third_party/lisp/asdf-flv/default.nix b/third_party/lisp/asdf-flv/default.nix new file mode 100644 index 0000000000..e8ec4aa8f8 --- /dev/null +++ b/third_party/lisp/asdf-flv/default.nix @@ -0,0 +1,13 @@ +# Imported from https://github.com/didierverna/asdf-flv +{ depot, ... }: + +with depot.nix; +buildLisp.library { + name = "asdf-flv"; + deps = [ (buildLisp.bundled "asdf") ]; + + srcs = [ + ./package.lisp + ./asdf-flv.lisp + ]; +} diff --git a/third_party/lisp/asdf-flv/net.didierverna.asdf-flv.asd b/third_party/lisp/asdf-flv/net.didierverna.asdf-flv.asd new file mode 100644 index 0000000000..41202746d0 --- /dev/null +++ b/third_party/lisp/asdf-flv/net.didierverna.asdf-flv.asd @@ -0,0 +1,43 @@ +;;; net.didierverna.asdf-flv.asd --- ASDF system definition + +;; Copyright (C) 2011, 2015 Didier Verna + +;; Author: Didier Verna <didier@didierverna.net> + +;; This file is part of ASDF-FLV. + +;; Copying and distribution of this file, with or without modification, +;; are permitted in any medium without royalty provided the copyright +;; notice and this notice are preserved. This file is offered as-is, +;; without any warranty. + + +;;; Commentary: + +;; Contents management by FCM version 0.1. + + +;;; Code: + +(asdf:defsystem :net.didierverna.asdf-flv + :long-name "ASDF File Local Variables" + :description "ASDF extension to provide support for file-local variables." + :long-description "\ +ASDF-FLV provides support for file-local variables through ASDF. A file-local +variable behaves like *PACKAGE* and *READTABLE* with respect to LOAD and +COMPILE-FILE: a new dynamic binding is created before processing the file, so +that any modification to the variable becomes essentially file-local. + +In order to make one or several variables file-local, use the macros +SET-FILE-LOCAL-VARIABLE(S)." + :author "Didier Verna" + :mailto "didier@didierverna.net" + :homepage "http://www.lrde.epita.fr/~didier/software/lisp/misc.php#asdf-flv" + :source-control "https://github.com/didierverna/asdf-flv" + :license "GNU All Permissive" + :version "2.1" + :serial t + :components ((:file "package") + (:file "asdf-flv"))) + +;;; net.didierverna.asdf-flv.asd ends here diff --git a/third_party/lisp/asdf-flv/package.lisp b/third_party/lisp/asdf-flv/package.lisp new file mode 100644 index 0000000000..1d7fb2bab4 --- /dev/null +++ b/third_party/lisp/asdf-flv/package.lisp @@ -0,0 +1,28 @@ +;;; package.lisp --- Package definition + +;; Copyright (C) 2011, 2015 Didier Verna + +;; Author: Didier Verna <didier@didierverna.net> + +;; This file is part of ASDF-FLV. + +;; Copying and distribution of this file, with or without modification, +;; are permitted in any medium without royalty provided the copyright +;; notice and this notice are preserved. This file is offered as-is, +;; without any warranty. + + +;;; Commentary: + +;; Contents management by FCM version 0.1. + + +;;; Code: + +(in-package :cl-user) + +(defpackage :net.didierverna.asdf-flv + (:use :cl) + (:export :set-file-local-variable :set-file-local-variables)) + +;;; package.lisp ends here diff --git a/third_party/lisp/babel.nix b/third_party/lisp/babel.nix new file mode 100644 index 0000000000..ae7c5dd23d --- /dev/null +++ b/third_party/lisp/babel.nix @@ -0,0 +1,31 @@ +# Babel is an encoding conversion library for Common Lisp. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.babel; +in depot.nix.buildLisp.library { + name = "babel"; + deps = [ + depot.third_party.lisp.alexandria + depot.third_party.lisp.trivial-features + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "packages.lisp" + "encodings.lisp" + "enc-ascii.lisp" + "enc-ebcdic.lisp" + "enc-ebcdic-int.lisp" + "enc-iso-8859.lisp" + "enc-unicode.lisp" + "enc-cp1251.lisp" + "enc-cp1252.lisp" + "jpn-table.lisp" + "enc-jpn.lisp" + "enc-gbk.lisp" + "enc-koi8.lisp" + "external-format.lisp" + "strings.lisp" + "gbk-map.lisp" + "sharp-backslash.lisp" + ]; +} diff --git a/third_party/lisp/bordeaux-threads.nix b/third_party/lisp/bordeaux-threads.nix new file mode 100644 index 0000000000..8a2e099508 --- /dev/null +++ b/third_party/lisp/bordeaux-threads.nix @@ -0,0 +1,24 @@ +# This library is meant to make writing portable multi-threaded apps +# in Common Lisp simple. +{ depot, pkgs, ... }: + +let + src = with pkgs; srcOnly lispPackages.bordeaux-threads; + getSrc = f: "${src}/src/${f}"; +in +depot.nix.buildLisp.library { + name = "bordeaux-threads"; + deps = [ depot.third_party.lisp.alexandria ]; + + srcs = map getSrc [ + "pkgdcl.lisp" + "bordeaux-threads.lisp" + ] ++ [ + { + sbcl = getSrc "impl-sbcl.lisp"; + ecl = getSrc "impl-ecl.lisp"; + } + ] ++ map getSrc [ + "default-implementations.lisp" + ]; +} diff --git a/third_party/lisp/cffi.nix b/third_party/lisp/cffi.nix new file mode 100644 index 0000000000..de1d0c2e8e --- /dev/null +++ b/third_party/lisp/cffi.nix @@ -0,0 +1,34 @@ +# CFFI purports to be the Common Foreign Function Interface. +{ depot, pkgs, ... }: + +with depot.nix; +let src = with pkgs; srcOnly lispPackages.cffi; +in buildLisp.library { + name = "cffi"; + deps = with depot.third_party.lisp; [ + alexandria + babel + trivial-features + (buildLisp.bundled "asdf") + ]; + + srcs = [ + { + ecl = src + "/src/cffi-ecl.lisp"; + sbcl = src + "/src/cffi-sbcl.lisp"; + ccl = src + "/src/cffi-openmcl.lisp"; + } + ] ++ map (f: src + ("/src/" + f)) [ + "package.lisp" + "utils.lisp" + "libraries.lisp" + "early-types.lisp" + "types.lisp" + "enum.lisp" + "strings.lisp" + "structures.lisp" + "functions.lisp" + "foreign-vars.lisp" + "features.lisp" + ]; +} diff --git a/third_party/lisp/chipz.nix b/third_party/lisp/chipz.nix new file mode 100644 index 0000000000..59e9914ee1 --- /dev/null +++ b/third_party/lisp/chipz.nix @@ -0,0 +1,26 @@ +# Common Lisp library for decompressing deflate, zlib, gzip, and bzip2 data +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.chipz; +in depot.nix.buildLisp.library { + name = "chipz"; + deps = [ (depot.nix.buildLisp.bundled "asdf") ]; + + srcs = map (f: src + ("/" + f)) [ + "chipz.asd" + "package.lisp" + "constants.lisp" + "conditions.lisp" + "dstate.lisp" + "types-and-tables.lisp" + "crc32.lisp" + "adler32.lisp" + "inflate-state.lisp" + "gzip.lisp" + "zlib.lisp" + "inflate.lisp" + "bzip2.lisp" + "decompress.lisp" + "stream.lisp" + ]; +} diff --git a/third_party/lisp/chunga.nix b/third_party/lisp/chunga.nix new file mode 100644 index 0000000000..d3f50bcb1a --- /dev/null +++ b/third_party/lisp/chunga.nix @@ -0,0 +1,22 @@ +# Portable chunked streams for Common Lisp +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.chunga; +in depot.nix.buildLisp.library { + name = "chunga"; + deps = with depot.third_party.lisp; [ + trivial-gray-streams + ]; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "specials.lisp" + "util.lisp" + "known-words.lisp" + "conditions.lisp" + "read.lisp" + "streams.lisp" + "input.lisp" + "output.lisp" + ]; +} diff --git a/third_party/lisp/cl-ansi-text.nix b/third_party/lisp/cl-ansi-text.nix new file mode 100644 index 0000000000..0e34015247 --- /dev/null +++ b/third_party/lisp/cl-ansi-text.nix @@ -0,0 +1,16 @@ +# Enables ANSI colors for printing. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-ansi-text; +in depot.nix.buildLisp.library { + name = "cl-ansi-text"; + deps = with depot.third_party.lisp; [ + alexandria + cl-colors2 + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "cl-ansi-text.lisp" + "define-colors.lisp" + ]; +} diff --git a/third_party/lisp/cl-base64.nix b/third_party/lisp/cl-base64.nix new file mode 100644 index 0000000000..08055a0471 --- /dev/null +++ b/third_party/lisp/cl-base64.nix @@ -0,0 +1,14 @@ +# Base64 encoding for Common Lisp +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-base64; +in depot.nix.buildLisp.library { + name = "cl-base64"; + srcs = [ + (src + "/package.lisp") + (src + "/encode.lisp") + (src + "/decode.lisp") + ]; +} + + diff --git a/third_party/lisp/cl-colors.nix b/third_party/lisp/cl-colors.nix new file mode 100644 index 0000000000..b51e4d46a7 --- /dev/null +++ b/third_party/lisp/cl-colors.nix @@ -0,0 +1,16 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-colors; +in depot.nix.buildLisp.library { + name = "cl-colors"; + deps = [ + depot.third_party.lisp.alexandria + depot.third_party.lisp.let-plus + ]; + srcs = [ + "${src}/package.lisp" + "${src}/colors.lisp" + "${src}/colornames.lisp" + "${src}/hexcolors.lisp" + ]; +} diff --git a/third_party/lisp/cl-colors2.nix b/third_party/lisp/cl-colors2.nix new file mode 100644 index 0000000000..34201bc2fa --- /dev/null +++ b/third_party/lisp/cl-colors2.nix @@ -0,0 +1,18 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-colors2; +in depot.nix.buildLisp.library { + name = "cl-colors2"; + deps = with depot.third_party.lisp; [ + alexandria + cl-ppcre + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "colors.lisp" + "colornames-x11.lisp" + "colornames-svg.lisp" + "hexcolors.lisp" + ]; +} diff --git a/third_party/lisp/cl-date-time-parser.nix b/third_party/lisp/cl-date-time-parser.nix new file mode 100644 index 0000000000..e53cb2dfce --- /dev/null +++ b/third_party/lisp/cl-date-time-parser.nix @@ -0,0 +1,21 @@ +{ depot, pkgs, ... }: + +depot.nix.buildLisp.library { + name = "cl-date-time-parser"; + + srcs = [ + (pkgs.fetchurl { + url = "https://raw.githubusercontent.com/tkych/cl-date-time-parser/00d6fc70b599f460fdf13cf0cf7e6bf843312410/date-time-parser.lisp"; + sha256 = "0zrkv1q3sx5ksijxhw45ixf1hy5b9biii6i6v41h12q6pbkfqz69"; + }) + ]; + + deps = [ + depot.third_party.lisp.alexandria + depot.third_party.lisp.anaphora + depot.third_party.lisp.split-sequence + depot.third_party.lisp.cl-ppcre + depot.third_party.lisp.local-time + depot.third_party.lisp.parse-float + ]; +} diff --git a/third_party/lisp/cl-fad.nix b/third_party/lisp/cl-fad.nix new file mode 100644 index 0000000000..9350abe2e3 --- /dev/null +++ b/third_party/lisp/cl-fad.nix @@ -0,0 +1,27 @@ +# Portable pathname library +{ depot, pkgs, ... }: + +with depot.nix; + +let src = with pkgs; srcOnly lispPackages.cl-fad; +in buildLisp.library { + name = "cl-fad"; + + deps = with depot.third_party.lisp; [ + alexandria + bordeaux-threads + { + sbcl = buildLisp.bundled "sb-posix"; + } + ]; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + ] ++ [ + { ccl = "${src}/openmcl.lisp"; } + ] ++ map (f: src + ("/" + f)) [ + "fad.lisp" + "path.lisp" + "temporary-files.lisp" + ]; +} diff --git a/third_party/lisp/cl-json.nix b/third_party/lisp/cl-json.nix new file mode 100644 index 0000000000..6b82fac772 --- /dev/null +++ b/third_party/lisp/cl-json.nix @@ -0,0 +1,53 @@ +# JSON encoder & decoder +{ depot, pkgs, ... }: + +let + inherit (depot.nix) buildLisp; + + # https://github.com/sharplispers/cl-json/pull/12/ + src = pkgs.fetchFromGitHub { + owner = "sternenseemann"; + repo = "cl-json"; + rev = "c059bec94e28a11102a994d6949e2e52764f21fd"; + sha256 = "0l07syw1b1x2zi8kj4iph3rf6vi6c16b7fk69iv7x27wrdsr1qwj"; + }; + + getSrcs = subdir: map (f: src + ("/" + subdir + "/" + f)); +in +buildLisp.library { + name = "cl-json"; + deps = [ (buildLisp.bundled "asdf") ]; + + srcs = [ "${src}/cl-json.asd" ] ++ + (getSrcs "src" [ + "package.lisp" + "common.lisp" + "objects.lisp" + "camel-case.lisp" + "decoder.lisp" + "encoder.lisp" + "utils.lisp" + "json-rpc.lisp" + ]); + + tests = { + deps = [ + depot.third_party.lisp.cl-unicode + depot.third_party.lisp.fiveam + ]; + srcs = [ + # CLOS tests are broken upstream as well + # https://github.com/sharplispers/cl-json/issues/11 + (pkgs.writeText "no-clos-tests.lisp" '' + (replace *features* (delete :cl-json-clos *features*)) + '') + ] ++ getSrcs "t" [ + "package.lisp" + "testencoder.lisp" + "testdecoder.lisp" + "testmisc.lisp" + ]; + + expression = "(fiveam:run! 'json-test::json)"; + }; +} diff --git a/third_party/lisp/cl-plus-ssl.nix b/third_party/lisp/cl-plus-ssl.nix new file mode 100644 index 0000000000..dc0a95944f --- /dev/null +++ b/third_party/lisp/cl-plus-ssl.nix @@ -0,0 +1,50 @@ +# Common Lisp bindings to OpenSSL +{ depot, pkgs, ... }: + +with depot.nix; + +let + src = pkgs.fetchgit { + url = "https://github.com/cl-plus-ssl/cl-plus-ssl.git"; + rev = "29081992f6d7b4e3aa2c5eeece4cd92b745071f4"; + hash = "sha256:16lyrixl98b7vy29dbbzkbq0xaz789350dajrr1gdny5i55rkjq0"; + }; +in +buildLisp.library { + name = "cl-plus-ssl"; + deps = with depot.third_party.lisp; [ + alexandria + bordeaux-threads + cffi + flexi-streams + trivial-features + trivial-garbage + trivial-gray-streams + { + scbl = buildLisp.bundled "uiop"; + default = buildLisp.bundled "asdf"; + } + { sbcl = buildLisp.bundled "sb-posix"; } + ]; + + native = [ pkgs.openssl ]; + + srcs = map (f: src + ("/src/" + f)) [ + "package.lisp" + "reload.lisp" + "conditions.lisp" + "ffi.lisp" + "x509.lisp" + "ffi-buffer-all.lisp" + "ffi-buffer.lisp" + "streams.lisp" + "bio.lisp" + "random.lisp" + "context.lisp" + "verify-hostname.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/cl-ppcre.nix b/third_party/lisp/cl-ppcre.nix new file mode 100644 index 0000000000..561e306191 --- /dev/null +++ b/third_party/lisp/cl-ppcre.nix @@ -0,0 +1,27 @@ +# cl-ppcre is a Common Lisp regular expression library. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-ppcre; +in depot.nix.buildLisp.library { + name = "cl-ppcre"; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "specials.lisp" + "util.lisp" + "errors.lisp" + "charset.lisp" + "charmap.lisp" + "chartest.lisp" + "lexer.lisp" + "parser.lisp" + "regex-class.lisp" + "regex-class-util.lisp" + "convert.lisp" + "optimize.lisp" + "closures.lisp" + "repetition-closures.lisp" + "scanner.lisp" + "api.lisp" + ]; +} diff --git a/third_party/lisp/cl-prevalence.nix b/third_party/lisp/cl-prevalence.nix new file mode 100644 index 0000000000..188cbc686d --- /dev/null +++ b/third_party/lisp/cl-prevalence.nix @@ -0,0 +1,25 @@ +# cl-prevalence is an implementation of object prevalence for CL (i.e. +# an in-memory database) +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-prevalence; +in depot.nix.buildLisp.library { + name = "cl-prevalence"; + + deps = with depot.third_party.lisp; [ + bordeaux-threads + s-xml + s-sysdeps + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "package.lisp" + "serialization/serialization.lisp" + "serialization/xml.lisp" + "serialization/sexp.lisp" + "prevalence.lisp" + "managed-prevalence.lisp" + "master-slave.lisp" + "blob.lisp" + ]; +} diff --git a/third_party/lisp/cl-smtp.nix b/third_party/lisp/cl-smtp.nix new file mode 100644 index 0000000000..7ab9bea59f --- /dev/null +++ b/third_party/lisp/cl-smtp.nix @@ -0,0 +1,24 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-smtp; +in depot.nix.buildLisp.library { + name = "cl-smtp"; + deps = with depot.third_party.lisp; [ + usocket + trivial-gray-streams + flexi-streams + cl-base64 + cl-plus-ssl + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "attachments.lisp" + "cl-smtp.lisp" + "mime-types.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/cl-unicode.nix b/third_party/lisp/cl-unicode.nix new file mode 100644 index 0000000000..815d99c2dc --- /dev/null +++ b/third_party/lisp/cl-unicode.nix @@ -0,0 +1,80 @@ +{ depot, pkgs, ... }: + +let + inherit (pkgs) sbcl runCommand writeText; + inherit (depot.nix.buildLisp) bundled; + + src = pkgs.fetchFromGitHub { + owner = "edicl"; + repo = "cl-unicode"; + rev = "8073fc5634c9d4802888ac03abf11dfe383e16fa"; + sha256 = "0ykx2s9lqfl74p1px0ik3l2izd1fc9jd1b4ra68s5x34rvjy0hza"; + }; + + cl-unicode-base = depot.nix.buildLisp.library { + name = "cl-unicode-base"; + deps = with depot.third_party.lisp; [ + cl-ppcre + ]; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "specials.lisp" + "util.lisp" + ]; + }; + + cl-unicode-build = depot.nix.buildLisp.program { + name = "cl-unicode-build"; + deps = with depot.third_party.lisp; [ + cl-unicode-base + flexi-streams + { + ecl = bundled "asdf"; + default = bundled "uiop"; + } + ]; + + srcs = (map (f: src + ("/build/" + f)) [ + "util.lisp" + "char-info.lisp" + "read.lisp" + ]) ++ [ + (runCommand "dump.lisp" { } '' + substitute ${src}/build/dump.lisp $out \ + --replace ':defaults *this-file*' ":defaults (uiop:getcwd)" + '') + + (writeText "export-create-source-files.lisp" '' + (in-package :cl-unicode) + (export 'create-source-files) + '') + ]; + + main = "cl-unicode:create-source-files"; + }; + + + generated = runCommand "cl-unicode-generated" { } '' + mkdir -p $out/build + mkdir -p $out/test + cd $out/build + pwd + ${cl-unicode-build}/bin/cl-unicode-build + ''; + +in +depot.nix.buildLisp.library { + name = "cl-unicode"; + deps = [ cl-unicode-base ]; + srcs = [ + "${src}/conditions.lisp" + "${generated}/lists.lisp" + "${generated}/hash-tables.lisp" + "${src}/api.lisp" + "${generated}/methods.lisp" + "${src}/test-functions.lisp" + "${src}/derived.lisp" + "${src}/alias.lisp" + ]; +} diff --git a/third_party/lisp/cl-who.nix b/third_party/lisp/cl-who.nix new file mode 100644 index 0000000000..601b09f118 --- /dev/null +++ b/third_party/lisp/cl-who.nix @@ -0,0 +1,13 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.cl-who; +in depot.nix.buildLisp.library { + name = "cl-who"; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "specials.lisp" + "util.lisp" + "who.lisp" + ]; +} diff --git a/third_party/lisp/cl-yacc.nix b/third_party/lisp/cl-yacc.nix new file mode 100644 index 0000000000..b40d5d0601 --- /dev/null +++ b/third_party/lisp/cl-yacc.nix @@ -0,0 +1,17 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "jech"; + repo = "cl-yacc"; + rev = "1334f5469251ffb3f8738a682dc8ee646cb26635"; + sha256 = "16946pzf8vvadnyfayvj8rbh4zjzw90h0azz2qk1mxrvhh5wklib"; + }; +in +depot.nix.buildLisp.library { + name = "cl-yacc"; + + srcs = map (f: src + ("/" + f)) [ + "yacc.lisp" + ]; +} diff --git a/third_party/lisp/closer-mop.nix b/third_party/lisp/closer-mop.nix new file mode 100644 index 0000000000..145b9cfd43 --- /dev/null +++ b/third_party/lisp/closer-mop.nix @@ -0,0 +1,19 @@ +# Closer to MOP is a compatibility layer that rectifies many of the +# absent or incorrect CLOS MOP features across a broad range of Common +# Lisp implementations +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.closer-mop; +in depot.nix.buildLisp.library { + name = "closer-mop"; + + srcs = [ + "${src}/closer-mop-packages.lisp" + "${src}/closer-mop-shared.lisp" + { + sbcl = "${src}/closer-sbcl.lisp"; + ecl = "${src}/closer-ecl.lisp"; + ccl = "${src}/closer-clozure.lisp"; + } + ]; +} diff --git a/third_party/lisp/closure-common.nix b/third_party/lisp/closure-common.nix new file mode 100644 index 0000000000..7f7f79f855 --- /dev/null +++ b/third_party/lisp/closure-common.nix @@ -0,0 +1,36 @@ +{ depot, pkgs, ... }: + +let + src = with pkgs; srcOnly lispPackages.closure-common; + getSrcs = builtins.map (p: "${src}/${p}"); +in +depot.nix.buildLisp.library { + name = "closure-common"; + + # closure-common.asd surpresses some warnings otherwise breaking + # compilation. Feature macros across implementations: + # + # ECL #+rune-is-character #-rune-is-integer #-x&y-streams-are-stream + # CCL #+rune-is-character #-rune-is-integer #-x&y-streams-are-stream + # SBCL #+rune-is-character #-rune-is-integer #-x&y-streams-are-stream + # + # Since all implementations agree, the alternative files aren't encoded here. + srcs = getSrcs [ + "closure-common.asd" + "package.lisp" + "definline.lisp" + "characters.lisp" #+rune-is-character + "syntax.lisp" + "encodings.lisp" #-x&y-streams-are-stream + "encodings-data.lisp" #-x&y-streams-are-stream + "xstream.lisp" #-x&y-streams-are-stream + "ystream.lisp" #-x&y-streams-are-stream + "hax.lisp" + ]; + + deps = [ + (depot.nix.buildLisp.bundled "asdf") + depot.third_party.lisp.trivial-gray-streams + depot.third_party.lisp.babel #+rune-is-character + ]; +} diff --git a/third_party/lisp/closure-html/default.nix b/third_party/lisp/closure-html/default.nix new file mode 100644 index 0000000000..1886ea2ec9 --- /dev/null +++ b/third_party/lisp/closure-html/default.nix @@ -0,0 +1,65 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.applyPatches { + name = "closure-html-source"; + src = pkgs.lispPackages.closure-html.src; + + patches = [ + # delete unexported and unused double defun in sgml-dtd.lisp + # which reference undefined CL-USER:*HTML-DTD* (!) which + # unlike CLOSURE-HTML:*HTML-DTD* is not involved in the + # packages operation. + ./no-double-defun.patch + # Patches html-parser.lisp to look for the distributed + # dtd files and catalog in this source derivations out + # path in the nix store instead of the same directory + # relatively to the (built) system. + ./dtds-from-store.patch + ]; + + postPatch = '' + # Inject file which defines CLOSURE-HTML:*HTML-DTD* + # early in the package's build since SBCL otherwise + # fails due to the undefined variable. Need to inject + # this via postPatch since using a nix file results + # in failure to look up the file's true name which + # is done for … reasons, apparently. + cat > src/define-html-dtd.lisp << EOF + (in-package :closure-html) + (defvar *html-dtd*) + EOF + + # Substitute reference to @out@ of this source + # directory in this patched file. + substituteAllInPlace src/parse/html-parser.lisp + ''; + }; + + getSrcs = builtins.map (p: "${src}/${p}"); +in + +depot.nix.buildLisp.library { + name = "closure-html"; + + srcs = getSrcs [ + "src/defpack.lisp" + "src/define-html-dtd.lisp" + "src/glisp/util.lisp" + "src/util/clex.lisp" + "src/util/lalr.lisp" + "src/net/mime.lisp" + "src/parse/pt.lisp" + "src/parse/sgml-dtd.lisp" + "src/parse/sgml-parse.lisp" + "src/parse/html-parser.lisp" + "src/parse/lhtml.lisp" + "src/parse/unparse.lisp" + "src/parse/documentation.lisp" + ]; + + deps = [ + depot.third_party.lisp.flexi-streams + depot.third_party.lisp.closure-common + ]; +} diff --git a/third_party/lisp/closure-html/dtds-from-store.patch b/third_party/lisp/closure-html/dtds-from-store.patch new file mode 100644 index 0000000000..a9ffd8085e --- /dev/null +++ b/third_party/lisp/closure-html/dtds-from-store.patch @@ -0,0 +1,16 @@ +diff --git a/src/parse/html-parser.lisp b/src/parse/html-parser.lisp +index 4e45b81..5025a26 100644 +--- a/src/parse/html-parser.lisp ++++ b/src/parse/html-parser.lisp +@@ -36,10 +36,7 @@ + (make-pathname + :name nil + :type nil +- :defaults (merge-pathnames +- "resources/" +- (asdf:component-relative-pathname +- (asdf:find-system :closure-html)))))) ++ :defaults "@out@/resources/"))) + (loop + :for (name . filename) + :in '(("-//W3O//DTD W3 HTML 3.0//EN" . "dtd/HTML-3.0") diff --git a/third_party/lisp/closure-html/no-double-defun.patch b/third_party/lisp/closure-html/no-double-defun.patch new file mode 100644 index 0000000000..ce7fb33abf --- /dev/null +++ b/third_party/lisp/closure-html/no-double-defun.patch @@ -0,0 +1,78 @@ +diff --git a/src/parse/sgml-dtd.lisp b/src/parse/sgml-dtd.lisp +index de774c0..dbee852 100644 +--- a/src/parse/sgml-dtd.lisp ++++ b/src/parse/sgml-dtd.lisp +@@ -624,73 +624,6 @@ + (return)))) + classes)) + +-;;;; ---------------------------------------------------------------------------------------------------- +-;;;; Compiled DTDs +-;;;; +- +-;; Since parsing and 'compiling' DTDs is slow, I'll provide for a way +-;; to (un)dump compiled DTD to stream. +- +-(defun dump-dtd (dtd sink) +- (let ((*print-pretty* nil) +- (*print-readably* t) +- (*print-circle* t)) +- (princ "#." sink) +- (prin1 +- `(MAKE-DTD :NAME ',(dtd-name dtd) +- :ELEMENTS (LET ((R (MAKE-HASH-TABLE :TEST #'EQ))) +- (SETF ,@(let ((q nil)) +- (maphash (lambda (key value) +- (push `',value q) +- (push `(GETHASH ',key R) q)) +- (dtd-elements dtd)) +- q)) +- R) +- :ENTITIES ',(dtd-entities dtd) +- :RESOLVE-INFO (LET ((R (MAKE-HASH-TABLE :TEST #'EQUAL))) +- (SETF ,@(let ((q nil)) +- (maphash (lambda (key value) +- (push `',value q) +- (push `(GETHASH ',key R) q)) +- (dtd-resolve-info dtd)) +- q)) +- R) +- ;; XXX surclusion-cache fehlt +- ) +- sink))) +- +-;;XXX +-(defun save-html-dtd () +- (with-open-file (sink "html-dtd.lisp" :direction :output :if-exists :new-version) +- (print `(in-package :sgml) sink) +- (let ((*package* (find-package :sgml))) +- (princ "(SETQ " sink) +- (prin1 'cl-user::*html-dtd* sink) +- (princ " '" sink) +- (dump-dtd cl-user::*html-dtd* sink) +- (princ ")" sink)))) +- +-;;; -------------------------------------------------------------------------------- +-;;; dumping DTDs +- +- +-(defun dump-dtd (dtd filename) +- (let ((*foo* dtd)) +- (declare (special *foo*)) +- (with-open-file (sink (merge-pathnames filename "*.lisp") +- :direction :output +- :if-exists :new-version) +- (format sink "(in-package :sgml)(locally (declare (special *foo*))(setq *foo* '#.*foo*))")) +- (compile-file (merge-pathnames filename "*.lisp")))) +- +-(defun undump-dtd (filename) +- (let (*foo*) +- (declare (special *foo*)) +- (load (compile-file-pathname (merge-pathnames filename "*.lisp")) +- :verbose nil +- :print nil) +- *foo*)) +- + (defmethod make-load-form ((self dtd) &optional env) + (declare (ignore env)) + `(make-dtd :name ',(dtd-name self) diff --git a/third_party/lisp/defclass-std.nix b/third_party/lisp/defclass-std.nix new file mode 100644 index 0000000000..c31ddb3c5b --- /dev/null +++ b/third_party/lisp/defclass-std.nix @@ -0,0 +1,16 @@ +# A shortcut macro to write DEFCLASS forms quickly +# Seems to be unmaintained (since early 2021) +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.defclass-std; +in depot.nix.buildLisp.library { + name = "defclass-std"; + deps = with depot.third_party.lisp; [ + alexandria + anaphora + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "defclass-std.lisp" + ]; +} diff --git a/third_party/lisp/drakma.nix b/third_party/lisp/drakma.nix new file mode 100644 index 0000000000..607f438d7e --- /dev/null +++ b/third_party/lisp/drakma.nix @@ -0,0 +1,34 @@ +# Drakma is an HTTP client for Common Lisp. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.drakma; +in depot.nix.buildLisp.library { + name = "drakma"; + deps = with depot.third_party.lisp; [ + chipz + chunga + cl-base64 + cl-plus-ssl + cl-ppcre + flexi-streams + puri + usocket + (depot.nix.buildLisp.bundled "asdf") + ]; + + srcs = map (f: src + ("/" + f)) [ + "drakma.asd" # Required because the system definition is used + "packages.lisp" + "specials.lisp" + "conditions.lisp" + "util.lisp" + "read.lisp" + "cookies.lisp" + "encoding.lisp" + "request.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/easy-routes.nix b/third_party/lisp/easy-routes.nix new file mode 100644 index 0000000000..5caf8261fa --- /dev/null +++ b/third_party/lisp/easy-routes.nix @@ -0,0 +1,30 @@ +{ depot, pkgs, ... }: + +let + + src = pkgs.fetchFromGitHub { + owner = "mmontone"; + repo = "easy-routes"; + rev = "dab613ff419a655036a00beecee026ab6e0ba430"; + sha256 = "06lnipwc6mmg0v5gybcnr7wn5xmn5xfd1gs19vbima777245bfka"; + }; + +in +depot.nix.buildLisp.library { + name = "easy-routes"; + deps = with depot.third_party.lisp; [ + hunchentoot + routes + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "util.lisp" + "easy-routes.lisp" + "routes-map-printer.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/fiveam.nix b/third_party/lisp/fiveam.nix new file mode 100644 index 0000000000..500e980a81 --- /dev/null +++ b/third_party/lisp/fiveam.nix @@ -0,0 +1,29 @@ +# FiveAM is a Common Lisp testing framework. +# +# Imported from https://github.com/sionescu/fiveam.git + +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.fiveam; +in depot.nix.buildLisp.library { + name = "fiveam"; + + deps = with depot.third_party.lisp; [ + alexandria + asdf-flv + trivial-backtrace + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "package.lisp" + "utils.lisp" + "check.lisp" + "fixture.lisp" + "classes.lisp" + "random.lisp" + "test.lisp" + "explain.lisp" + "suite.lisp" + "run.lisp" + ]; +} diff --git a/third_party/lisp/flexi-streams.nix b/third_party/lisp/flexi-streams.nix new file mode 100644 index 0000000000..a6a06d4ad0 --- /dev/null +++ b/third_party/lisp/flexi-streams.nix @@ -0,0 +1,33 @@ +# Flexible bivalent streams for Common Lisp +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.flexi-streams; +in depot.nix.buildLisp.library { + name = "flexi-streams"; + deps = [ depot.third_party.lisp.trivial-gray-streams ]; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "mapping.lisp" + "ascii.lisp" + "koi8-r.lisp" + "mac.lisp" + "iso-8859.lisp" + "enc-cn-tbl.lisp" + "code-pages.lisp" + "specials.lisp" + "util.lisp" + "conditions.lisp" + "external-format.lisp" + "length.lisp" + "encode.lisp" + "decode.lisp" + "in-memory.lisp" + "stream.lisp" + "output.lisp" + "input.lisp" + "io.lisp" + "strings.lisp" + ]; +} + diff --git a/third_party/lisp/global-vars.nix b/third_party/lisp/global-vars.nix new file mode 100644 index 0000000000..a3d27a09b6 --- /dev/null +++ b/third_party/lisp/global-vars.nix @@ -0,0 +1,7 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.global-vars; +in depot.nix.buildLisp.library { + name = "global-vars"; + srcs = [ "${src}/global-vars.lisp" ]; +} diff --git a/third_party/lisp/hunchentoot.nix b/third_party/lisp/hunchentoot.nix new file mode 100644 index 0000000000..e2480cd349 --- /dev/null +++ b/third_party/lisp/hunchentoot.nix @@ -0,0 +1,62 @@ +# Hunchentoot is a web framework for Common Lisp. +{ depot, pkgs, ... }: + +let + src = with pkgs; srcOnly lispPackages.hunchentoot; + + url-rewrite = depot.nix.buildLisp.library { + name = "url-rewrite"; + + srcs = map (f: src + ("/url-rewrite/" + f)) [ + "packages.lisp" + "specials.lisp" + "primitives.lisp" + "util.lisp" + "url-rewrite.lisp" + ]; + }; +in +depot.nix.buildLisp.library { + name = "hunchentoot"; + + deps = with depot.third_party.lisp; [ + alexandria + bordeaux-threads + chunga + cl-base64 + cl-fad + rfc2388 + cl-plus-ssl + cl-ppcre + flexi-streams + md5 + trivial-backtrace + usocket + url-rewrite + ]; + + srcs = map (f: src + ("/" + f)) [ + "hunchentoot.asd" + "packages.lisp" + "compat.lisp" + "specials.lisp" + "conditions.lisp" + "mime-types.lisp" + "util.lisp" + "log.lisp" + "cookie.lisp" + "reply.lisp" + "request.lisp" + "session.lisp" + "misc.lisp" + "headers.lisp" + "set-timeouts.lisp" + "taskmaster.lisp" + "acceptor.lisp" + "easy-handlers.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/ironclad.nix b/third_party/lisp/ironclad.nix new file mode 100644 index 0000000000..324c5da265 --- /dev/null +++ b/third_party/lisp/ironclad.nix @@ -0,0 +1,163 @@ +{ depot, pkgs, ... }: + +let + inherit (pkgs) runCommand; + inherit (depot.nix.buildLisp) bundled; + src = with pkgs; srcOnly lispPackages.ironclad; + getSrc = f: "${src}/src/${f}"; + +in +depot.nix.buildLisp.library { + name = "ironclad"; + + deps = with depot.third_party.lisp; [ + (bundled "asdf") + { sbcl = bundled "sb-rotate-byte"; } + { sbcl = bundled "sb-posix"; } + alexandria + bordeaux-threads + nibbles + ]; + + srcs = map getSrc [ + # { + # # TODO(grfn): Figure out how to get this compiling with the assembly + # # optimization eventually - see https://cl.tvl.fyi/c/depot/+/1333 + # sbcl = runCommand "package.lisp" {} '' + # substitute ${src}/src/package.lisp $out \ + # --replace \#-ecl-bytecmp "" \ + # --replace '(pushnew :ironclad-assembly *features*)' "" + # ''; + # default = getSrc "package.lisp"; + # } + "package.lisp" + "conditions.lisp" + "generic.lisp" + "macro-utils.lisp" + "util.lisp" + ] ++ [ + { sbcl = getSrc "opt/sbcl/fndb.lisp"; } + { sbcl = getSrc "opt/sbcl/cpu-features.lisp"; } + { sbcl = getSrc "opt/sbcl/x86oid-vm.lisp"; } + + { ecl = getSrc "opt/ecl/c-functions.lisp"; } + + { ccl = getSrc "opt/ccl/x86oid-vm.lisp"; } + ] ++ map getSrc [ + "common.lisp" + + "ciphers/cipher.lisp" + "ciphers/padding.lisp" + "ciphers/make-cipher.lisp" + "ciphers/modes.lisp" + + # subsystem def ironclad/ciphers + "ciphers/aes.lisp" + "ciphers/arcfour.lisp" + "ciphers/aria.lisp" + "ciphers/blowfish.lisp" + "ciphers/camellia.lisp" + "ciphers/cast5.lisp" + "ciphers/chacha.lisp" + "ciphers/des.lisp" + "ciphers/idea.lisp" + "ciphers/kalyna.lisp" + "ciphers/kuznyechik.lisp" + "ciphers/misty1.lisp" + "ciphers/rc2.lisp" + "ciphers/rc5.lisp" + "ciphers/rc6.lisp" + "ciphers/salsa20.lisp" + "ciphers/keystream.lisp" + "ciphers/seed.lisp" + "ciphers/serpent.lisp" + "ciphers/sm4.lisp" + "ciphers/sosemanuk.lisp" + "ciphers/square.lisp" + "ciphers/tea.lisp" + "ciphers/threefish.lisp" + "ciphers/twofish.lisp" + "ciphers/xchacha.lisp" + "ciphers/xor.lisp" + "ciphers/xsalsa20.lisp" + "ciphers/xtea.lisp" + + "digests/digest.lisp" + # subsystem def ironclad/digests + "digests/adler32.lisp" + "digests/blake2.lisp" + "digests/blake2s.lisp" + "digests/crc24.lisp" + "digests/crc32.lisp" + "digests/groestl.lisp" + "digests/jh.lisp" + "digests/kupyna.lisp" + "digests/md2.lisp" + "digests/md4.lisp" + "digests/md5.lisp" + "digests/md5-lispworks-int32.lisp" + "digests/ripemd-128.lisp" + "digests/ripemd-160.lisp" + "digests/sha1.lisp" + "digests/sha256.lisp" + "digests/sha3.lisp" + "digests/sha512.lisp" + "digests/skein.lisp" + "digests/sm3.lisp" + "digests/streebog.lisp" + "digests/tiger.lisp" + "digests/tree-hash.lisp" + "digests/whirlpool.lisp" + + "macs/mac.lisp" + # subsystem def ironclad/macs + "macs/blake2-mac.lisp" + "macs/blake2s-mac.lisp" + "macs/cmac.lisp" + "macs/hmac.lisp" + "macs/gmac.lisp" + "macs/poly1305.lisp" + "macs/siphash.lisp" + "macs/skein-mac.lisp" + + "prng/prng.lisp" + "prng/os-prng.lisp" + "prng/generator.lisp" + "prng/fortuna.lisp" + + "math.lisp" + + "octet-stream.lisp" + + "aead/aead.lisp" + # subsystem def ironclad/aead + "aead/eax.lisp" + "aead/etm.lisp" + "aead/gcm.lisp" + + "kdf/kdf.lisp" + # subsystem def ironclad/kdfs + "kdf/argon2.lisp" + "kdf/bcrypt.lisp" + "kdf/hmac.lisp" + "kdf/pkcs5.lisp" + "kdf/password-hash.lisp" + "kdf/scrypt.lisp" + + "public-key/public-key.lisp" + "public-key/pkcs1.lisp" + "public-key/elliptic-curve.lisp" + # subsystem def ironclad/public-keys + "public-key/dsa.lisp" + "public-key/rsa.lisp" + "public-key/elgamal.lisp" + "public-key/curve25519.lisp" + "public-key/curve448.lisp" + "public-key/ed25519.lisp" + "public-key/ed448.lisp" + "public-key/secp256k1.lisp" + "public-key/secp256r1.lisp" + "public-key/secp384r1.lisp" + "public-key/secp521r1.lisp" + ]; +} diff --git a/third_party/lisp/iterate.nix b/third_party/lisp/iterate.nix new file mode 100644 index 0000000000..b7d60265ac --- /dev/null +++ b/third_party/lisp/iterate.nix @@ -0,0 +1,12 @@ +# iterate is an iteration construct for Common Lisp, similar to the +# LOOP macro. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.iterate; +in depot.nix.buildLisp.library { + name = "iterate"; + srcs = [ + "${src}/package.lisp" + "${src}/iterate.lisp" + ]; +} diff --git a/third_party/lisp/lass.nix b/third_party/lisp/lass.nix new file mode 100644 index 0000000000..00f66c1fe3 --- /dev/null +++ b/third_party/lisp/lass.nix @@ -0,0 +1,35 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "Shinmera"; + repo = "LASS"; + rev = "f51b9e941ee0a2a1f76ba814dcef22f9fb5f69bf"; + sha256 = "11mxzyx34ynsfsrs8pgrarqi9s442vkpmh7kdpzvarhj7i97g8yx"; + }; + +in +depot.nix.buildLisp.library { + name = "lass"; + + deps = with depot.third_party.lisp; [ + trivial-indent + trivial-mimes + physical-quantities + parse-float + cl-base64 + (depot.nix.buildLisp.bundled "asdf") + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "readable-list.lisp" + "compiler.lisp" + "property-funcs.lisp" + "writer.lisp" + "lass.lisp" + "special.lisp" + "units.lisp" + "asdf.lisp" + ]; +} diff --git a/third_party/lisp/let-plus.nix b/third_party/lisp/let-plus.nix new file mode 100644 index 0000000000..bd7f31dfa0 --- /dev/null +++ b/third_party/lisp/let-plus.nix @@ -0,0 +1,15 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.let-plus; +in depot.nix.buildLisp.library { + name = "let-plus"; + deps = [ + depot.third_party.lisp.alexandria + depot.third_party.lisp.anaphora + ]; + srcs = [ + "${src}/package.lisp" + "${src}/let-plus.lisp" + "${src}/extensions.lisp" + ]; +} diff --git a/third_party/lisp/lisp-binary.nix b/third_party/lisp/lisp-binary.nix new file mode 100644 index 0000000000..296112cc9e --- /dev/null +++ b/third_party/lisp/lisp-binary.nix @@ -0,0 +1,33 @@ +# A library to easily read and write complex binary formats. +{ depot, pkgs, ... }: + +let + src = pkgs.srcOnly pkgs.lispPackages.lisp-binary; +in +depot.nix.buildLisp.library { + name = "lisp-binary"; + + deps = with depot.third_party.lisp; [ + alexandria + cffi + closer-mop + flexi-streams + moptilities + quasiquote_2 + ]; + + srcs = map (f: src + ("/" + f)) [ + "utils.lisp" + "integer.lisp" + "float.lisp" + "simple-bit-stream.lisp" + "reverse-stream.lisp" + "binary-1.lisp" + "binary-2.lisp" + "types.lisp" + ]; + + brokenOn = [ + "ecl" # TODO(sterni): disable conditionally cffi for ECL + ]; +} diff --git a/third_party/lisp/local-time.nix b/third_party/lisp/local-time.nix new file mode 100644 index 0000000000..1358408d38 --- /dev/null +++ b/third_party/lisp/local-time.nix @@ -0,0 +1,22 @@ +# Library for manipulating dates & times +{ depot, pkgs, ... }: + +let + inherit (depot.nix) buildLisp; + src = with pkgs; srcOnly lispPackages.local-time; +in +buildLisp.library { + name = "local-time"; + deps = [ + depot.third_party.lisp.cl-fad + { + scbl = buildLisp.bundled "uiop"; + default = buildLisp.bundled "asdf"; + } + ]; + + srcs = [ + "${src}/src/package.lisp" + "${src}/src/local-time.lisp" + ]; +} diff --git a/third_party/lisp/marshal.nix b/third_party/lisp/marshal.nix new file mode 100644 index 0000000000..73a1664a01 --- /dev/null +++ b/third_party/lisp/marshal.nix @@ -0,0 +1,13 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.marshal; +in depot.nix.buildLisp.library { + name = "marshal"; + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "serialization-format.lisp" + "coding-idiom.lisp" + "marshal.lisp" + "unmarshal.lisp" + ]; +} diff --git a/third_party/lisp/md5.nix b/third_party/lisp/md5.nix new file mode 100644 index 0000000000..8c3e255f16 --- /dev/null +++ b/third_party/lisp/md5.nix @@ -0,0 +1,16 @@ +# MD5 hash implementation +{ depot, pkgs, ... }: + +with depot.nix; + +let src = with pkgs; srcOnly lispPackages.md5; +in buildLisp.library { + name = "md5"; + deps = [ + { + sbcl = buildLisp.bundled "sb-rotate-byte"; + default = depot.third_party.lisp.flexi-streams; + } + ]; + srcs = [ (src + "/md5.lisp") ]; +} diff --git a/third_party/lisp/metabang-bind.nix b/third_party/lisp/metabang-bind.nix new file mode 100644 index 0000000000..fc046d0895 --- /dev/null +++ b/third_party/lisp/metabang-bind.nix @@ -0,0 +1,16 @@ +{ depot, pkgs, ... }: + +let + getSrcs = builtins.map (p: "${pkgs.srcOnly pkgs.lispPackages.metabang-bind}/${p}"); +in + +depot.nix.buildLisp.library { + name = "metabang-bind"; + + srcs = getSrcs [ + "dev/packages.lisp" + "dev/macros.lisp" + "dev/bind.lisp" + "dev/binding-forms.lisp" + ]; +} diff --git a/third_party/lisp/mime4cl/.skip-subtree b/third_party/lisp/mime4cl/.skip-subtree new file mode 100644 index 0000000000..5051f60d6b --- /dev/null +++ b/third_party/lisp/mime4cl/.skip-subtree @@ -0,0 +1 @@ +prevent readTree from creating entries for subdirs that don't contain an .nix files diff --git a/third_party/lisp/mime4cl/OWNERS b/third_party/lisp/mime4cl/OWNERS new file mode 100644 index 0000000000..2e95807063 --- /dev/null +++ b/third_party/lisp/mime4cl/OWNERS @@ -0,0 +1 @@ +sterni diff --git a/third_party/lisp/mime4cl/README.md b/third_party/lisp/mime4cl/README.md new file mode 100644 index 0000000000..2704d481ed --- /dev/null +++ b/third_party/lisp/mime4cl/README.md @@ -0,0 +1,27 @@ +# mime4cl + +`MIME4CL` is a Common Lisp library for dealing with MIME messages. It was +originally been written by Walter C. Pelissero and vendored into depot +([mime4cl-20150207T211851.tbz](http://wcp.sdf-eu.org/software/mime4cl-20150207T211851.tbz) +to be exact) as upstream has become inactive. Its [original +website](http://wcp.sdf-eu.org/software/#mime4cl) can still be accessed. + +The depot version has since diverged from upstream. Main aims were to improve +performance and reduce code size by relying on third party libraries like +flexi-streams. It is planned to improve encoding handling in the long term. +Currently, the library is being worked on intermittently and not very well +tested—**it may not work as expected**. + +## Differences from the original version + +* `//nix/buildLisp` is used as the build system. ASDF is currently untested and + may be broken. + +* The dependency on [sclf](http://wcp.sdf-eu.org/software/#sclf) has been + eliminated by inlining the relevant parts. + +* `MY-STRING-INPUT-STREAM`, `DELIMITED-INPUT-STREAM`, + `CHARACTER-INPUT-ADAPTER-STREAM`, `BINARY-INPUT-ADAPTER-STREAM` etc. have been + replaced by (thin wrappers around) flexi-streams. In addition to improved + handling of encodings, this allows using `READ-SEQUENCE` via the gray stream + interface. diff --git a/third_party/lisp/mime4cl/address.lisp b/third_party/lisp/mime4cl/address.lisp new file mode 100644 index 0000000000..42688a595b --- /dev/null +++ b/third_party/lisp/mime4cl/address.lisp @@ -0,0 +1,300 @@ +;;; address.lisp --- e-mail address parser + +;;; Copyright (C) 2007, 2008, 2009 by Walter C. Pelissero +;;; Copyright (C) 2022-2023 The TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;; Although not MIME specific, this parser is often useful together +;;; with the MIME primitives. It should be able to parse the address +;;; syntax described in RFC2822 excluding the obsolete syntax (see +;;; RFC822). Have a look at the test suite to get an idea of what +;;; kind of addresses it can parse. + +(in-package :mime4cl) + +(defstruct (mailbox (:conc-name mbx-)) + description + user + host + domain) + +(defstruct (mailbox-group (:conc-name mbxg-)) + name + mailboxes) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun write-mailbox-domain-name (addr &optional (stream *standard-output*)) + (when (eq :internet (mbx-domain addr)) + (write-char #\[ stream)) + (write-string (mbx-host addr) stream) + (when (eq :internet (mbx-domain addr)) + (write-char #\] stream)) + (when (stringp (mbx-domain addr)) + (write-char #\. stream) + (write-string (mbx-domain addr) stream))) + +(defun write-mailbox-address (addr &optional (stream *standard-output*)) + (write-string (mbx-user addr) stream) + (when (mbx-host addr) + (write-char #\@ stream) + (write-mailbox-domain-name addr stream))) + +(defmethod mbx-domain-name ((MBX mailbox)) + "Return the complete domain name string of MBX, in the form +\"host.domain\"." + (with-output-to-string (out) + (write-mailbox-domain-name mbx out))) + +(defmethod mbx-address ((mbx mailbox)) + "Return the e-mail address string of MBX, in the form +\"user@host.domain\"." + (with-output-to-string (out) + (write-mailbox-address mbx out))) + +(defun write-mailbox (addr &optional (stream *standard-output*)) + (awhen (mbx-description addr) + (write it :stream stream :readably t) + (write-string " <" stream)) + (write-mailbox-address addr stream) + (awhen (mbx-description addr) + (write-char #\> stream))) + +(defun write-mailbox-group (grp &optional (stream *standard-output*)) + (write-string (mbxg-name grp) stream) + (write-string ": " stream) + (loop + for mailboxes on (mbxg-mailboxes grp) + for mailbox = (car mailboxes) + do (write-mailbox mailbox stream) + unless (endp (cdr mailboxes)) + do (write-string ", " stream)) + (write-char #\; stream)) + +(defmethod print-object ((mbx mailbox) stream) + (if (or *print-readably* *print-escape*) + (call-next-method) + (write-mailbox mbx stream))) + +(defmethod print-object ((grp mailbox-group) stream) + (if (or *print-readably* *print-escape*) + (call-next-method) + (write-mailbox-group grp stream))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun parser-make-mailbox (description address-list) + (make-mailbox :description description + :user (car address-list) + :host (cadr address-list) + :domain (when (cddr address-list) + (string-concat (cddr address-list) ".")))) + + +(defun populate-grammar () + (defrule address-list + := (+ address ",")) + + (defrule address + := mailbox + := group) + + (defrule mailbox + := display-name? angle-addr comment? + :reduce (parser-make-mailbox (or display-name comment) angle-addr) + := addr-spec comment? + :reduce (parser-make-mailbox comment addr-spec)) + + (defrule angle-addr + := "<" addr-spec ">") + + (defrule group + := display-name ":" mailbox-list ";" + :reduce (make-mailbox-group :name display-name :mailboxes mailbox-list)) + + (defrule display-name + := phrase + :reduce (string-concat phrase " ")) + + (defrule phrase + := word+) + + (defrule word + := atext + := string) + + (defrule mailbox-list + := (+ mailbox ",")) + + (defrule addr-spec + := local-part "@" domain :reduce (cons local-part domain)) + + (defrule local-part + := dot-atom :reduce (string-concat dot-atom ".") + := string) + + (defrule domain + := dot-atom + := domain-literal :reduce (list domain-literal :internet)) + + ;; actually, according to the RFC, dot-atoms don't allow spaces in + ;; between but these rules do + (defrule dot-atom + := (+ atom ".")) + + (defrule atom + := atext+ + :reduce (apply #'concatenate 'string atext))) + +(deflazy define-grammar + (let ((*package* #.*package*) + (*compile-print* (when npg::*debug* t))) + (reset-grammar) + (format t "~&creating e-mail address grammar...~%") + (populate-grammar) + (let ((grammar (npg:generate-grammar #'string=))) + (reset-grammar) + (npg:print-grammar-figures grammar) + grammar))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The lexical analyser + +(defstruct cursor + stream + (position 0)) + +(defun read-delimited-string (stream end-char &key nesting-start-char (escape-char #\\)) + (labels ((collect () + (with-output-to-string (out) + (loop + for c = (read-char stream nil) + while (and c (not (char= c end-char))) + do (cond ((char= c escape-char) + (awhen (read-char stream nil) + (write-char it out))) + ((and nesting-start-char + (char= c nesting-start-char)) + (write-char nesting-start-char out) + (write-string (collect) out) + (write-char end-char out)) + (t (write-char c out))))))) + (collect))) + + +(defun read-string (cursor) + (make-token :type 'string + :value (read-delimited-string (cursor-stream cursor) #\") + :position (incf (cursor-position cursor)))) + +(defun read-domain-literal (cursor) + (make-token :type 'domain-literal + :value (read-delimited-string (cursor-stream cursor) #\]) + :position (incf (cursor-position cursor)))) + +(defun read-comment (cursor) + (make-token :type 'comment + :value (read-delimited-string (cursor-stream cursor) #\) :nesting-start-char #\() + :position (incf (cursor-position cursor)))) + +(declaim (inline atom-component-p)) +(defun atom-component-p (c) + (declare (type character c)) + (not (find c " ()\"[]@.<>:;,"))) + +(defun read-atext (first-character cursor) + (let ((string (with-output-to-string (out) + (write-char first-character out) + (loop + for c = (read-char (cursor-stream cursor) nil) + while (and c (atom-component-p c)) + do (write-char c out) + finally (when c + (unread-char c (cursor-stream cursor))))))) + (make-token :type 'atext + :value string + :position (incf (cursor-position cursor))))) + +(defmethod read-next-tokens ((cursor cursor)) + (flet ((make-keyword (c) + (make-token :type 'keyword + :value (string c) + :position (incf (cursor-position cursor))))) + (let ((in (cursor-stream cursor))) + (loop + for c = (read-char in nil) + while c + unless (whitespace-p c) + return (list + (cond ((char= #\( c) + (read-comment cursor)) + ((char= #\" c) + (read-string cursor)) + ((char= #\[ c) + (read-domain-literal cursor)) + ((find c "@.<>:;,") + (make-keyword c)) + (t + ;; anything else is considered a text atom even + ;; though it's just a single character + (read-atext c cursor)))))))) + +(defun analyse-string (string) + "Return the list of tokens produced by a lexical analysis of +STRING. These are the tokens that would be seen by the parser." + (with-input-from-string (stream string) + (let ((cursor (make-cursor :stream stream))) + (loop + for tokens = (read-next-tokens cursor) + until (endp tokens) + append tokens)))) + +(defun mailboxes-only (list-of-mailboxes-and-groups) + "Return a flat list of MAILBOX-ADDRESSes from +LIST-OF-MAILBOXES-AND-GROUPS, which is the kind of list returned +by PARSE-ADDRESSES. This turns out to be useful when your +program is not interested in mailbox groups and expects the user +addresses only." + (mapcan #'(lambda (mbx) + (if (typep mbx 'mailbox-group) + (mbxg-mailboxes mbx) + (list mbx))) + list-of-mailboxes-and-groups)) + +(defun parse-addresses (string &key no-groups) + "Parse STRING and return a list of MAILBOX-ADDRESSes or +MAILBOX-GROUPs. If STRING is unparsable return NIL. If +NO-GROUPS is true, return a flat list of mailboxes throwing away +the group containers, if any." + (let ((grammar (force define-grammar))) + (with-input-from-string (stream string) + (let* ((cursor (make-cursor :stream stream)) + (mailboxes (ignore-errors ; ignore parsing errors + (parse grammar 'address-list cursor)))) + (if no-groups + (mailboxes-only mailboxes) + mailboxes))))) + +(defun debug-addresses (string) + "More or less like PARSE-ADDRESSES, but don't ignore parsing errors." + (let ((grammar (force define-grammar))) + (with-input-from-string (stream string) + (let ((cursor (make-cursor :stream stream))) + (parse grammar 'address-list cursor))))) + diff --git a/third_party/lisp/mime4cl/default.nix b/third_party/lisp/mime4cl/default.nix new file mode 100644 index 0000000000..99b23c91aa --- /dev/null +++ b/third_party/lisp/mime4cl/default.nix @@ -0,0 +1,50 @@ +# Copyright (C) 2021 by the TVL Authors +# SPDX-License-Identifier: LGPL-2.1-or-later +{ depot, pkgs, ... }: + +depot.nix.buildLisp.library { + name = "mime4cl"; + + deps = [ + depot.third_party.lisp.flexi-streams + depot.third_party.lisp.npg + depot.third_party.lisp.trivial-gray-streams + depot.third_party.lisp.qbase64 + ]; + + srcs = [ + ./ex-sclf.lisp + ./package.lisp + ./endec.lisp + ./streams.lisp + ./mime.lisp + ./address.lisp + ]; + + tests = { + name = "mime4cl-tests"; + + srcs = [ + ./test/rt.lisp + ./test/package.lisp + (pkgs.writeText "nix-samples.lisp" '' + (in-package :mime4cl-tests) + + ;; override auto discovery which doesn't work in the nix store + (defvar *samples-directory* (pathname "${./test/samples}/")) + '') + ./test/temp-file.lisp + ./test/endec.lisp + ./test/address.lisp + ./test/mime.lisp + ]; + + expression = "(rtest:do-tests)"; + }; + + # limited by sclf + brokenOn = [ + "ccl" + "ecl" + ]; +} diff --git a/third_party/lisp/mime4cl/endec.lisp b/third_party/lisp/mime4cl/endec.lisp new file mode 100644 index 0000000000..2e282c2378 --- /dev/null +++ b/third_party/lisp/mime4cl/endec.lisp @@ -0,0 +1,663 @@ +;;; endec.lisp --- encoder/decoder functions + +;;; Copyright (C) 2005-2008, 2010 by Walter C. Pelissero +;;; Copyright (C) 2023 by The TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + + +(in-package :mime4cl) + +(defun redirect-stream (in out &key (buffer-size 4096)) + "Consume input stream IN and write all its content to output stream OUT. +The streams' element types need to match." + (let ((buf (make-array buffer-size :element-type (stream-element-type in)))) + (loop for pos = (read-sequence buf in) + while (> pos 0) + do (write-sequence buf out :end pos)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Thank you SBCL for rendering constants totally useless! +(defparameter +base64-encode-table+ + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=") + +(declaim (type simple-string +base64-encode-table+)) + +(defvar *base64-line-length* 76 + "Maximum length of the encoded base64 line. NIL means it can +be of unlimited length \(no line breaks will be done by the +encoding function).") + +(defvar *quoted-printable-line-length* 72 + "Maximum length of the encoded quoted printable line. NIL +means it can be of unlimited length \(no line breaks will be done +by the encoding function).") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass decoder () + ((input-function :initarg :input-function + :reader decoder-input-function + :type function + :documentation + "Function is called repeatedly by the decoder methods to get the next character. +It should return a character os NIL (indicating EOF).")) + (:documentation + "Abstract base class for decoders.")) + +(defclass parsing-decoder (decoder) + ((parser-errors :initform nil + :initarg :parser-errors + :reader decoder-parser-errors + :type boolean)) + (:documentation + "Abstract base class for decoders that do parsing.")) + +(defclass encoder () + ((output-function :initarg :output-function + :reader encoder-output-function + :type function + :documentation + "Function is called repeatedly by the encoder methods to output a character. +It should expect a character as its only argument.")) + (:documentation + "Abstract base class for encoders.")) + +(defclass line-encoder (encoder) + ((column :initform 0 + :type fixnum) + (line-length :initarg :line-length + :initform nil + :reader encoder-line-length + :type (or fixnum null))) + (:documentation + "Abstract base class for line encoders.")) + +(defclass 8bit-decoder (decoder) + () + (:documentation + "Class for decoders that do nothing.")) + +(defclass 8bit-encoder (encoder) + () + (:documentation + "Class for encoders that do nothing.")) + +(defclass 7bit-decoder (decoder) + () + (:documentation + "Class for decoders that do nothing.")) + +(defclass 7bit-encoder (encoder) + () + (:documentation + "Class for encoders that do nothing.")) + +(defclass byte-decoder (decoder) + () + (:documentation + "Class for decoders that turns chars to bytes.")) + +(defclass byte-encoder (encoder) + () + (:documentation + "Class for encoders that turns bytes to chars.")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric encoder-write-byte (encoder byte)) +(defgeneric encoder-finish-output (encoder)) +(defgeneric decoder-read-byte (decoder)) + +(defmethod encoder-finish-output ((encoder encoder)) + (values)) + +(defmethod encoder-write-byte ((encoder 8bit-encoder) byte) + (funcall (slot-value encoder 'output-function) + (code-char byte)) + (values)) + +(defmethod decoder-read-byte ((decoder 8bit-decoder)) + (awhen (funcall (slot-value decoder 'input-function)) + (char-code it))) + +(defmethod encoder-write-byte ((encoder 7bit-encoder) byte) + (funcall (slot-value encoder 'output-function) + (code-char (logand #x7F byte))) + (values)) + +(defmethod decoder-read-byte ((decoder 7bit-decoder)) + (awhen (funcall (slot-value decoder 'input-function)) + (logand #x7F (char-code it)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun decoder-read-sequence (sequence decoder &key (start 0) (end (length sequence))) + (declare (optimize (speed 3) (safety 0) (debug 0)) + (type fixnum start end) + (type vector sequence)) + (loop + for i fixnum from start below end + for byte = (decoder-read-byte decoder) + while byte + do (setf (aref sequence i) byte) + finally (return i))) + +(defun decoder-read-line (decoder) + (with-output-to-string (str) + (loop + for byte = (decoder-read-byte decoder) + unless byte + do (return-from decoder-read-line nil) + do (let ((c (code-char byte))) + (cond ((char= c #\return) + ;; skip the newline + (decoder-read-byte decoder) + (return nil)) + ((char= c #\newline) + ;; the #\return was missing + (return nil)) + (t (write-char c str))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declaim (inline parse-hex)) +(defun parse-hex (c1 c2) + "Parse two characters as hexadecimal and return their combined +value." + (declare (optimize (speed 3) (safety 0) (debug 0)) + (type character c1 c2)) + (flet ((digit-value (char) + (or (position char "0123456789ABCDEF") + (return-from parse-hex nil)))) + (+ (* 16 (digit-value c1)) + (digit-value c2)))) + +(defclass quoted-printable-decoder (parsing-decoder) + ((saved-bytes :initform (make-queue)))) + +(defmethod decoder-read-byte ((decoder quoted-printable-decoder)) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (with-slots (input-function saved-bytes parser-errors) decoder + (declare (type function input-function)) + (labels ((saveb (b) + (queue-append saved-bytes b) + (values)) + (save (c) + (saveb (char-code c))) + (push-next () + (let ((c (funcall input-function))) + (declare (type (or null character) c)) + (cond ((not c)) + ((or (char= c #\space) + (char= c #\tab)) + (save c) + (push-next)) + ((char= c #\=) + (let ((c1 (funcall input-function))) + (cond ((not c1) + (save #\=)) + ((char= c1 #\return) + ;; soft line break: skip the next + ;; character which we assume to be a + ;; newline (pity if it isn't) + (funcall input-function) + (push-next)) + ((char= c1 #\newline) + ;; soft line break: the #\return is + ;; missing, but we are tolerant + (push-next)) + (t + ;; hexadecimal sequence: get the 2nd digit + (let ((c2 (funcall input-function))) + (if c2 + (aif (parse-hex c1 c2) + (saveb it) + (if parser-errors + (error "invalid hex sequence ~A~A" c1 c2) + (progn + (save #\=) + (save c1) + (save c2)))) + (progn + (save c) + (save c1)))))))) + (t + (save c)))))) + (or (queue-pop saved-bytes) + (progn + (push-next) + (queue-pop saved-bytes)))))) + +(defmacro make-encoder-loop (encoder-class input-form output-form) + (with-gensyms (encoder byte) + `(loop + with ,encoder = (make-instance ',encoder-class + :output-function #'(lambda (char) ,output-form)) + for ,byte = ,input-form + while ,byte + do (encoder-write-byte ,encoder ,byte) + finally (encoder-finish-output ,encoder)))) + +(defmacro make-decoder-loop (decoder-class input-form output-form &key parser-errors) + (with-gensyms (decoder) + `(loop + with ,decoder = (make-instance ',decoder-class + :input-function #'(lambda () ,input-form) + :parser-errors ,parser-errors) + for byte = (decoder-read-byte ,decoder) + while byte + do ,output-form))) + +(defun decode-quoted-printable-stream (in out &key parser-errors) + "Read from stream IN a quoted printable text and write to +binary output OUT the decoded stream of bytes." + (make-decoder-loop quoted-printable-decoder + (read-byte in nil) (write-byte byte out) + :parser-errors parser-errors)) + +(defmacro make-stream-to-sequence-decoder (decoder-class input-form &key parser-errors) + "Decode the character stream STREAM and return a sequence of bytes." + (with-gensyms (output-sequence) + `(let ((,output-sequence (make-array 0 + :element-type '(unsigned-byte 8) + :fill-pointer 0 + :adjustable t))) + (make-decoder-loop ,decoder-class ,input-form + (vector-push-extend byte ,output-sequence) + :parser-errors ,parser-errors) + ,output-sequence))) + +(defun decode-quoted-printable-stream-to-sequence (stream &key parser-errors) + "Read from STREAM a quoted printable text and return a vector of +bytes." + (make-stream-to-sequence-decoder quoted-printable-decoder + (read-char stream nil) + :parser-errors parser-errors)) + +(defun decode-quoted-printable-string (string &key (start 0) (end (length string)) parser-errors) + "Decode STRING as quoted printable sequence of characters and +return a decoded sequence of bytes." + (with-input-from-string (in string :start start :end end) + (decode-quoted-printable-stream-to-sequence in :parser-errors parser-errors))) + +(defclass quoted-printable-encoder (line-encoder) + ((line-length :initform *quoted-printable-line-length* + :type (or fixnum null)) + (pending-space :initform nil + :type boolean))) + +(defmethod encoder-write-byte ((encoder quoted-printable-encoder) byte) + (declare (optimize (speed 3) (safety 0) (debug 0)) + (type (unsigned-byte 8) byte)) + (with-slots (output-function column pending-space line-length) encoder + (declare (type function output-function) + (type fixnum column) + (type (or fixnum null) line-length) + (type boolean pending-space)) + (labels ((out (c) + (funcall output-function c) + (values)) + (outs (str) + (declare (type simple-string str)) + (loop + for c across str + do (out c)) + (values)) + (out2hex (x) + (declare (type fixnum x)) + (multiple-value-bind (a b) (truncate x 16) + (out (digit-char a 16)) + (out (digit-char b 16))))) + (cond ((= byte #.(char-code #\newline)) + (when pending-space + (outs "=20") + (setf pending-space nil)) + (out #\newline) + (setf column 0)) + ((= byte #.(char-code #\space)) + (if pending-space + (progn + (out #\space) + (f++ column)) + (setf pending-space t))) + (t + (when pending-space + (out #\space) + (f++ column) + (setf pending-space nil)) + (cond ((or (< byte 32) + (= byte #.(char-code #\=)) + (> byte 126)) + (out #\=) + (out2hex byte) + (f++ column 3)) + (t + (out (code-char byte)) + (f++ column))))) + (when (and line-length + (>= column line-length)) + ;; soft line break + (outs #.(coerce '(#\= #\newline) 'string)) + (setf column 0))))) + +(defmethod encoder-finish-output ((encoder quoted-printable-encoder)) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (with-slots (pending-space output-function) encoder + (declare (type boolean pending-space) + (type function output-function)) + (when pending-space + (flet ((outs (s) + (declare (type simple-string s)) + (loop + for c across s + do (funcall output-function c)))) + (setf pending-space nil) + (outs "=20"))))) + +(defun encode-quoted-printable-stream (in out) + "Read from IN a stream of bytes and write to OUT a stream of +characters quoted printables encoded." + (make-encoder-loop quoted-printable-encoder + (read-byte in nil) + (write-char char out))) + +(defun encode-quoted-printable-sequence-to-stream (sequence stream &key (start 0) (end (length sequence))) + "Encode the sequence of bytes SEQUENCE and write to STREAM a +quoted printable sequence of characters." + (let ((i start)) + (make-encoder-loop quoted-printable-encoder + (when (< i end) + (prog1 (elt sequence i) + (f++ i))) + (write-char char stream)))) + +(defun encode-quoted-printable-sequence (sequence &key (start 0) (end (length sequence))) + "Encode the sequence of bytes SEQUENCE into a quoted printable +string and return it." + (with-output-to-string (out) + (encode-quoted-printable-sequence-to-stream sequence out :start start :end end))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass base64-encoder (line-encoder) + ((line-length :initform *base64-line-length*) + (bitstore :initform 0 + :type fixnum) + (bytecount :initform 0 + :type fixnum)) + (:documentation + "Class for Base64 encoder output streams.")) + + +(eval-when (:load-toplevel :compile-toplevel) + (unless (> most-positive-fixnum (expt 2 (* 8 3))))) + +(macrolet ((with-encoder (encoder &body forms) + `(with-slots (bitstore line-length column bytecount output-function) ,encoder + (declare (type fixnum column) + (type fixnum bitstore bytecount) + (type (or fixnum null) line-length) + (type function output-function)) + (labels ((emitr (i b) + (declare (type fixnum i b)) + (unless (zerop i) + (emitr (1- i) (ash b -6))) + (emitc + (char +base64-encode-table+ (logand b #x3F))) + (values)) + (out (c) + (funcall output-function c)) + (eol () + (progn + (out #\return) + (out #\newline))) + (emitc (char) + (out char) + (f++ column) + (when (and line-length + (>= column line-length)) + (setf column 0) + (eol)))) + (declare (inline out eol emitc) + (ignorable (function emitr) (function out) (function eol) (function emitc))) + ,@forms)))) + ;; For this function to work correctly, the FIXNUM must be at least + ;; 24 bits. + (defmethod encoder-write-byte ((encoder base64-encoder) byte) + (declare (optimize (speed 3) (safety 0) (debug 0)) + (type (unsigned-byte 8) byte)) + (with-encoder encoder + (setf bitstore (logior byte (the fixnum (ash bitstore 8)))) + (f++ bytecount) + (when (= 3 bytecount) + (emitr 3 bitstore) + (setf bitstore 0 + bytecount 0))) + (values)) + + (defmethod encoder-finish-output ((encoder base64-encoder)) + (with-encoder encoder + (unless (zerop bytecount) + (multiple-value-bind (saved6 rest) (truncate (* bytecount 8) 6) + (setf bitstore (ash bitstore (- 6 rest))) + (emitr saved6 bitstore) + (dotimes (x (- 3 saved6)) + (emitc #\=)))) + (when (and line-length + (not (zerop column))) + (eol))) + (values))) + +(defun encode-base64-stream (in out) + "Read a byte stream from IN and write to OUT the encoded Base64 +character stream." + (make-encoder-loop base64-encoder (read-byte in nil) + (write-char char out))) + +(defun encode-base64-sequence-to-stream (sequence stream &key (start 0) (end (length sequence))) + "Encode the sequence of bytes SEQUENCE and write to STREAM the +Base64 character sequence." + (let ((i start)) + (make-encoder-loop base64-encoder + (when (< i end) + (prog1 (elt sequence i) + (incf i))) + (write-char char stream)))) + +(defun encode-base64-sequence (sequence &key (start 0) (end (length sequence))) + "Encode the sequence of bytes SEQUENCE into a Base64 string and +return it." + (with-output-to-string (out) + (encode-base64-sequence-to-stream sequence out :start start :end end))) + +(defun decode-base64-stream (in out &key parser-errors) + "Read from IN a stream of characters Base64 encoded and write +to OUT a stream of decoded bytes." + ;; parser-errors are ignored for base64 + (declare (ignore parser-errors)) + (redirect-stream (make-instance 'qbase64:decode-stream + :underlying-stream in) + out)) + +(defun decode-base64-stream-to-sequence (stream &key parser-errors) + "Read Base64 characters from STREAM and return result of decoding them as a +binary sequence." + ;; parser-errors are ignored for base64 + (declare (ignore parser-errors)) + (let* ((buffered-size 4096) + (dstream (make-instance 'qbase64:decode-stream + :underlying-stream stream)) + (output-seq (make-array buffered-size + :element-type '(unsigned-byte 8) + :adjustable t))) + (loop for cap = (array-dimension output-seq 0) + for pos = (read-sequence output-seq dstream :start (or pos 0)) + if (>= pos cap) + do (adjust-array output-seq (+ cap buffered-size)) + else + do (progn + (adjust-array output-seq pos) + (return output-seq))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun dump-stream-binary (in out) + "Write content of IN character stream to OUT binary stream." + (loop + for c = (read-char in nil) + while c + do (write-byte (char-code c) out))) + +(defun decode-string (string encoding &key parser-errors-p) + (gcase (encoding string-equal) + (:quoted-printable + (decode-quoted-printable-string string + :parser-errors parser-errors-p)) + (:base64 + ;; parser-errors-p is unused in base64 + (qbase64:decode-string string)) + (otherwise + (map '(vector (unsigned-byte 8)) #'char-code string)))) + +(defun decode-stream-to-sequence (stream encoding &key parser-errors-p) + (gcase (encoding string-equal) + (:quoted-printable + (decode-quoted-printable-stream-to-sequence stream + :parser-errors parser-errors-p)) + (:base64 + (decode-base64-stream-to-sequence stream + :parser-errors parser-errors-p)) + (otherwise + (loop + with output-sequence = (make-array 0 :fill-pointer 0 + :element-type '(unsigned-byte 8) + :adjustable t) + for c = (read-char stream nil) + while c + do (vector-push-extend (char-code c) output-sequence) + finally (return output-sequence))))) + +(defun encode-stream (in out encoding) + (gcase (encoding string-equal) + (:quoted-printable + (encode-quoted-printable-stream in out)) + (:base64 + (encode-base64-stream in out)) + (otherwise + (loop + for byte = (read-byte in nil) + while byte + do (write-char (code-char byte) out))))) + +(defun encode-sequence-to-stream (sequence out encoding) + (gcase (encoding string-equal) + (:quoted-printable + (encode-quoted-printable-sequence-to-stream sequence out)) + (:base64 + (encode-base64-sequence-to-stream sequence out)) + (otherwise + (loop + for byte across sequence + do (write-char (code-char byte) out))))) + +(defun encode-sequence (sequence encoding) + (gcase (encoding string-equal) + (:quoted-printable + (encode-quoted-printable-sequence sequence)) + (:base64 + (encode-base64-sequence sequence)) + (otherwise + (map 'string #'code-char sequence)))) + +;; This is similar to decode-quoted-printable-string but #\_ is used +;; instead of space +(defun decode-quoted-printable-RFC2047-string (string &key (start 0) (end (length string))) + "Decode a string encoded according to the quoted printable +method of RFC2047 and return a sequence of bytes." + (declare (optimize (speed 3) (debug 0) (safety 0)) + (type simple-string string)) + (loop + with output-sequence = (make-array (length string) + :element-type '(unsigned-byte 8) + :fill-pointer 0) + for i fixnum from start by 1 below end + for c = (char string i) + do (case c + (#\= + (vector-push-extend (or (parse-hex (char string (1+ i)) (char string (+ 2 i))) + ;; the char code was malformed + #.(char-code #\?)) + output-sequence) + (f++ i 2)) + (#\_ (vector-push-extend #.(char-code #\space) output-sequence)) + (otherwise + (vector-push-extend (char-code c) output-sequence))) + finally (return output-sequence))) + +(defun decode-RFC2047-part (encoding string &key (start 0) (end (length string))) + "Decode STRING according to RFC2047 and return a sequence of +bytes." + (gcase (encoding string-equal) + ("Q" (decode-quoted-printable-RFC2047-string string :start start :end end)) + ("B" (qbase64:decode-string (subseq string start end))) + (t string))) + +(defun parse-RFC2047-text (text) + "Parse the string TEXT according to RFC2047 rules and return a list +of pairs and strings. The strings are the bits interposed between the +actually encoded text. The pairs are composed of: a decoded byte +sequence, a charset string indicating the original coding." + (loop + with result = '() + with previous-end = 0 + for start = (search "=?" text :start2 previous-end) + while start + for first-? = (position #\? text :start (+ 2 start)) + while first-? + for second-? = (position #\? text :start (1+ first-?)) + while second-? + for end = (search "?=" text :start2 (1+ second-?)) + while end + do (let ((charset (string-upcase (subseq text (+ 2 start) first-?))) + (encoding (subseq text (1+ first-?) second-?))) + (unless (= previous-end start) + (push (subseq text previous-end start) + result)) + (setf previous-end (+ end 2)) + (push (cons (decode-RFC2047-part encoding text :start (1+ second-?) :end end) + charset) + result)) + finally (unless (= previous-end (length text)) + (push (subseq text previous-end (length text)) + result)) + (return (nreverse result)))) + +(defun decode-RFC2047 (text) + "Decode TEXT into a fully decoded string. Whenever a non ASCII part is + encountered, try to decode it using flexi-streams, otherwise signal an error." + (flet ((decode-part (part) + (etypecase part + (cons (flexi-streams:octets-to-string + (car part) + :external-format (flexi-streams:make-external-format + (intern (string-upcase (cdr part)) 'keyword)))) + (string part)))) + (apply #'concatenate + (cons 'string + (mapcar #'decode-part (mime:parse-RFC2047-text text)))))) diff --git a/third_party/lisp/mime4cl/ex-sclf.lisp b/third_party/lisp/mime4cl/ex-sclf.lisp new file mode 100644 index 0000000000..7951b44f4d --- /dev/null +++ b/third_party/lisp/mime4cl/ex-sclf.lisp @@ -0,0 +1,368 @@ +;;; ex-sclf.lisp --- subset of sclf used by mime4cl + +;;; Copyright (C) 2005-2010 by Walter C. Pelissero +;;; Copyright (C) 2022-2023 The TVL Authors + +;;; Author: sternenseemann <sternenseemann@systemli.org> +;;; Project: mime4cl +;;; +;;; mime4cl uses sclf for miscellaneous utility functions. sclf's portability +;;; is quite limited. Since mime4cl is the only thing in TVL's depot depending +;;; on sclf, it made more sense to strip down sclf to the extent mime4cl needed +;;; in order to lessen the burden of porting it to other CL implementations +;;; later. +;;; +;;; Eventually it probably makes sense to drop the utilities we don't like and +;;; merge the ones we do like into depot's own utility package, klatre. + +#+cmu (ext:file-comment "$Module: ex-sclf.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(defpackage :mime4cl-ex-sclf + (:use :common-lisp) + (:export + #:aif + #:awhen + #:aand + #:it + + #:gcase + + #:with-gensyms + + #:split-at + #:split-string-at-char + #:+whitespace+ + #:whitespace-p + #:string-concat + #:s+ + #:string-starts-with + #:string-trim-whitespace + #:string-left-trim-whitespace + #:string-right-trim-whitespace + + #:queue + #:make-queue + #:queue-append + #:queue-pop + #:queue-empty-p + + #:save-file-excursion + #:read-file + + #:unix-file-stat + #:unix-stat + #:file-size + + #:promise + #:make-promise + #:lazy + #:force + #:forced-p + #:deflazy + + #:f++ + + #:week-day->string + #:month->string)) + +(in-package :mime4cl-ex-sclf) + +;; MACRO UTILS + +(defmacro with-gensyms ((&rest symbols) &body body) + "Gensym all SYMBOLS and make them available in BODY. +See also LET-GENSYMS." + `(let ,(mapcar #'(lambda (s) + (list s '(gensym))) symbols) + ,@body)) + +;; CONTROL FLOW + +(defmacro aif (test then &optional else) + `(let ((it ,test)) + (if it + ,then + ,else))) + +(defmacro awhen (test &body then) + `(let ((it ,test)) + (when it + ,@then))) + +(defmacro aand (&rest args) + (cond ((null args) t) + ((null (cdr args)) (car args)) + (t `(aif ,(car args) (aand ,@(cdr args)))))) + +(defmacro gcase ((value &optional (test 'equalp)) &rest cases) + "Generic CASE macro. Match VALUE to CASES as if by the normal CASE +but use TEST as the comparison function, which defaults to EQUALP." + (with-gensyms (val) + `(let ((,val ,value)) + ,(cons 'cond + (mapcar #'(lambda (case-desc) + (destructuring-bind (vals &rest forms) case-desc + `(,(cond ((consp vals) + (cons 'or (mapcar #'(lambda (v) + (list test val v)) + vals))) + ((or (eq vals 'otherwise) + (eq vals t)) + t) + (t (list test val vals))) + ,@forms))) + cases))))) + +;; SEQUENCES + +(defun position-any (bag sequence &rest position-args) + "Find any element of bag in sequence and return its position. +Accept any argument accepted by the POSITION function." + (apply #'position-if #'(lambda (element) + (find element bag)) sequence position-args)) + +(defun split-at (bag sequence &key (start 0) key) + "Split SEQUENCE at occurence of any element from BAG. +Contiguous occurences of elements from BAG are considered atomic; +so no empty sequence is returned." + (let ((len (length sequence))) + (labels ((split-from (start) + (unless (>= start len) + (let ((sep (position-any bag sequence :start start :key key))) + (cond ((not sep) + (list (subseq sequence start))) + ((> sep start) + (cons (subseq sequence start sep) + (split-from (1+ sep)))) + (t + (split-from (1+ start)))))))) + (split-from start)))) + +;; STRINGS + +(defvar +whitespace+ '(#\return #\newline #\tab #\space #\page)) + +(defun whitespace-p (char) + (member char +whitespace+)) + +(defun string-trim-whitespace (string) + (string-trim +whitespace+ string)) + +(defun string-right-trim-whitespace (string) + (string-right-trim +whitespace+ string)) + +(defun string-left-trim-whitespace (string) + (string-left-trim +whitespace+ string)) + +(defun split-string-at-char (string separator &key escape skip-empty) + "Split STRING at SEPARATORs and return a list of the substrings. If +SKIP-EMPTY is true then filter out the empty substrings. If ESCAPE is +not nil then split at SEPARATOR only if it's not preceded by ESCAPE." + (declare (type string string) (type character separator)) + (labels ((next-separator (beg) + (let ((pos (position separator string :start beg))) + (if (and escape + pos + (plusp pos) + (char= escape (char string (1- pos)))) + (next-separator (1+ pos)) + pos))) + (parse (beg) + (cond ((< beg (length string)) + (let* ((end (next-separator beg)) + (substring (subseq string beg end))) + (cond ((and skip-empty (string= "" substring)) + (parse (1+ end))) + ((not end) + (list substring)) + (t + (cons substring (parse (1+ end))))))) + (skip-empty + '()) + (t + (list ""))))) + (parse 0))) + +(defun s+ (&rest strings) + "Return a string which is made of the concatenation of STRINGS." + (apply #'concatenate 'string strings)) + +(defun string-concat (list &optional (separator "")) + "Concatenate the strings in LIST interposing SEPARATOR (default +nothing) between them." + (reduce #'(lambda (&rest args) + (if args + (s+ (car args) separator (cadr args)) + "")) + list)) + +(defun string-starts-with (prefix string &optional (compare #'string=)) + (let ((prefix-length (length prefix))) + (and (>= (length string) prefix-length) + (funcall compare prefix string :end2 prefix-length)))) + +;; QUEUE + +(defstruct queue + first + last) + +(defgeneric queue-append (queue objects)) +(defgeneric queue-pop (queue)) +(defgeneric queue-empty-p (queue)) + +(defmethod queue-append ((queue queue) (objects list)) + (cond ((null (queue-first queue)) + (setf (queue-first queue) objects + (queue-last queue) (last objects))) + (t + (setf (cdr (queue-last queue)) objects + (queue-last queue) (last objects)))) + queue) + +(defmethod queue-append ((queue queue) object) + (queue-append queue (list object))) + +(defmethod queue-pop ((queue queue)) + (prog1 (car (queue-first queue)) + (setf (queue-first queue) (cdr (queue-first queue))))) + +(defmethod queue-empty-p ((queue queue)) + (null (queue-first queue))) + +;; STREAMS + +(defmacro save-file-excursion ((stream &optional position) &body forms) + "Execute FORMS returning, on exit, STREAM to the position it was +before FORMS. Optionally POSITION can be set to the starting offset." + (unless position + (setf position (gensym))) + `(let ((,position (file-position ,stream))) + (unwind-protect (progn ,@forms) + (file-position ,stream ,position)))) + +(defun read-file (pathname &key (element-type 'character) (if-does-not-exist :error) default) + "Read the whole content of file and return it as a sequence which +can be a string, a vector of bytes, or whatever you specify as +ELEMENT-TYPE." + (with-open-file (in pathname + :element-type element-type + :if-does-not-exist (unless (eq :value if-does-not-exist) + :error)) + (if in + (let ((seq (make-array (file-length in) :element-type element-type))) + (read-sequence seq in) + seq) + default))) + +;; FILES + +(defun native-namestring (pathname) + #+sbcl (sb-ext:native-namestring pathname) + #-sbcl (let (#+cmu (lisp::*ignore-wildcards* t)) + (namestring pathname))) + +(defstruct (unix-file-stat (:conc-name stat-)) + device + inode + links + atime + mtime + ctime + size + blksize + blocks + uid + gid + mode) + +(defun unix-stat (pathname) + ;; this could be different depending on the unix systems + (multiple-value-bind (ok? device inode mode links uid gid rdev + size atime mtime ctime + blksize blocks) + (#+cmu unix:unix-lstat + #+sbcl sb-unix:unix-lstat + ;; TODO(sterni): ECL, CCL + (if (stringp pathname) + pathname + (native-namestring pathname))) + (declare (ignore rdev)) + (when ok? + (make-unix-file-stat :device device + :inode inode + :links links + :atime atime + :mtime mtime + :ctime ctime + :size size + :blksize blksize + :blocks blocks + :uid uid + :gid gid + :mode mode)))) + +;; FILE-LENGTH is a bit idiosyncratic in this respect. Besides, Unix +;; allows to get to know the file size without being able to open a +;; file; just ask politely. +(defun file-size (pathname) + (stat-size (unix-stat pathname))) + +;; LAZY + +(defstruct promise + procedure + value) + +(defmacro lazy (form) + `(make-promise :procedure #'(lambda () ,form))) + +(defun forced-p (promise) + (null (promise-procedure promise))) + +(defun force (promise) + (if (forced-p promise) + (promise-value promise) + (prog1 (setf (promise-value promise) + (funcall (promise-procedure promise))) + (setf (promise-procedure promise) nil)))) + +(defmacro deflazy (name value &optional documentation) + `(defparameter ,name (lazy ,value) + ,@(when documentation + (list documentation)))) + +;; FIXNUMS + +(defmacro f++ (x &optional (delta 1)) + "Same as INCF but hopefully optimised for fixnums." + `(setf ,x (+ (the fixnum ,x) (the fixnum ,delta)))) + +;; TIME + +(defun week-day->string (day &optional sunday-first) + "Return the weekday string corresponding to DAY number." + (elt (if sunday-first + #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) + day)) + +(defvar +month-names+ #("January" "February" "March" "April" "May" "June" "July" + "August" "September" "October" "November" "December")) + +(defun month->string (month) + "Return the month string corresponding to MONTH number." + (elt +month-names+ (1- month))) diff --git a/third_party/lisp/mime4cl/mime.lisp b/third_party/lisp/mime4cl/mime.lisp new file mode 100644 index 0000000000..3cdac4b26b --- /dev/null +++ b/third_party/lisp/mime4cl/mime.lisp @@ -0,0 +1,1049 @@ +;;; mime4cl.lisp --- MIME primitives for Common Lisp + +;;; Copyright (C) 2005-2008, 2010 by Walter C. Pelissero +;;; Copyright (C) 2021-2023 by the TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :mime4cl) + +(defclass mime-part () + ((subtype + :type (or string null) + :initarg :subtype + :accessor mime-subtype + ;; some mime types don't require a subtype + :initform nil) + (type-parameters + :type list + :initarg :type-parameters + :initform '() + :accessor mime-type-parameters) + (version + :type (or string null) + :initarg :mime-version + :initform "1.0" + :accessor mime-version) + (id + :initform nil + :initarg :id + :reader mime-id) + (description + :initform nil + :initarg :description + :accessor mime-description) + (encoding + :initform :7bit + :initarg :encoding + :reader mime-encoding + :documentation + "It's supposed to be either: + :7BIT, :8BIT, :BINARY, :QUOTED-PRINTABLE, :BASE64, a + X-token or an ietf-token (whatever that means).") + (disposition + :type (or string null) + :initarg :disposition + :initform nil + :accessor mime-disposition) + (disposition-parameters + :type list + :initarg :disposition-parameters + :initform '() + :accessor mime-disposition-parameters)) + (:documentation + "Abstract base class for all types of MIME parts.")) + +(defclass mime-bodily-part (mime-part) + ((body + :initarg :body + :accessor mime-body)) + (:documentation + "Abstract base class for MIME parts with a body.")) + +(defclass mime-unknown-part (mime-bodily-part) + ((type + :initarg :type + :reader mime-type + :documentation + "The original type string from the MIME header.")) + (:documentation + "MIME part unknown to this library. Accepted but not handled.")) + +(defclass mime-text (mime-bodily-part) ()) + +;; This turns out to be handy when making methods specialised +;; non-textual attachments. +(defclass mime-binary (mime-bodily-part) ()) + +(defclass mime-image (mime-binary) ()) + +(defclass mime-audio (mime-binary) ()) + +(defclass mime-video (mime-binary) ()) + +(defclass mime-application (mime-binary) ()) + +(defclass mime-multipart (mime-part) + ((parts :initarg :parts + :accessor mime-parts))) + +(defclass mime-message (mime-part) + ((headers :initarg :headers + :initform '() + :type list + :accessor mime-message-headers) + (real-message :initarg :body + :accessor mime-body))) + +(defun mime-part-p (object) + (typep object 'mime-part)) + +(defmethod initialize-instance ((part mime-multipart) &key &allow-other-keys) + (call-next-method) + ;; The initialization argument of the PARTS slot of a mime-multipart + ;; is expected to be a list of mime-parts. Thus, we implicitly + ;; create the mime parts using the arguments found in this list. + (with-slots (parts) part + (when (slot-boundp part 'parts) + (setf parts + (mapcar #'(lambda (subpart) + (if (mime-part-p subpart) + subpart + (apply #'make-instance subpart))) + parts))))) + +(defmethod initialize-instance ((part mime-message) &key &allow-other-keys) + (call-next-method) + ;; Allow a list of mime parts to be specified as body of a + ;; mime-message. In that case we implicitly create a mime-multipart + ;; and assign to the body slot. + (with-slots (real-message) part + (when (and (slot-boundp part 'real-message) + (consp real-message)) + (setf real-message + (make-instance 'mime-multipart :parts real-message))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun alist= (alist1 alist2 &key (test #'eql)) + (null + (set-difference alist1 alist2 + :test #'(lambda (x y) + (and (funcall test (car x) (car y)) + (funcall test (cdr x) (cdr y))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric mime= (mime1 mime2) + (:documentation + "Return true if MIME1 and MIME2 have equivalent structure and identical bodies (as for EQ).")) + +(defmethod mime= ((part1 mime-part) (part2 mime-part)) + (macrolet ((null-or (compare x y) + `(or (and (not ,x) + (not ,y)) + (and ,x ,y + (,compare ,x ,y)))) + (cmp-slot (compare reader) + `(null-or ,compare (,reader part1) (,reader part2)))) + (and (eq (class-of part1) (class-of part2)) + (cmp-slot string-equal mime-subtype) + (alist= (mime-type-parameters part1) + (mime-type-parameters part2) + :test #'string-equal) + (cmp-slot string= mime-id) + (cmp-slot string= mime-description) + (cmp-slot eq mime-encoding) + (cmp-slot equal mime-disposition) + (alist= (mime-disposition-parameters part1) + (mime-disposition-parameters part2) + :test #'string-equal)))) + +(defmethod mime= ((part1 mime-multipart) (part2 mime-multipart)) + (and (call-next-method) + (every #'mime= (mime-parts part1) (mime-parts part2)))) + +(defmethod mime= ((part1 mime-message) (part2 mime-message)) + (and (call-next-method) + (alist= (mime-message-headers part1) (mime-message-headers part2) + :test #'string=) + (mime= (mime-body part1) (mime-body part2)))) + +(defun mime-body-stream (mime-part) + (make-input-adapter (mime-body mime-part))) + +(defun mime-body-length (mime-part) + (let ((body (mime-body mime-part))) + ;; here the stream type is missing on purpose, because we may not + ;; be able to size the length of a stream + (etypecase body + (string + (length body)) + (vector + (length body)) + (pathname + (file-size body)) + (file-portion + (with-open-stream (in (open-decoded-file-portion body)) + (loop + for byte = (read-byte in nil) + while byte + count byte)))))) + +(defmacro with-input-from-mime-body-stream ((stream part) &body forms) + `(with-open-stream (,stream (mime-body-stream ,part)) + ,@forms)) + +(defmethod mime= ((part1 mime-bodily-part) (part2 mime-bodily-part)) + (and (call-next-method) + (with-input-from-mime-body-stream (in1 part1) + (with-input-from-mime-body-stream (in2 part2) + (loop + for b1 = (read-byte in1 nil) + for b2 = (read-byte in2 nil) + always (eq b1 b2) + while (and b1 b2)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric get-mime-type-parameter (part name) + (:documentation + "Return the MIME type parameter associated to NAME of PART.")) + +(defgeneric (setf get-mime-type-parameter) (value part name) + (:documentation + "Set the MIME type parameter associated to NAME of PART.")) + +(defmethod get-mime-type-parameter ((part mime-part) name) + (cdr (assoc name (mime-type-parameters part) :test #'string-equal))) + +(defmethod (setf get-mime-type-parameter) (value part name) + (aif (assoc name (mime-type-parameters part) :test #'string-equal) + (setf (cdr it) value) + (push (cons name value) + (mime-type-parameters part))) + value) + +(defgeneric get-mime-disposition-parameter (part name) + (:documentation + "Return the MIME disposition parameter associated to NAME of PART.")) + +(defmethod get-mime-disposition-parameter ((part mime-part) name) + (cdr (assoc name (mime-disposition-parameters part) :test #'string-equal))) + +(defmethod (setf get-mime-disposition-parameter) (value part name) + (aif (assoc name (mime-disposition-parameters part) :test #'string-equal) + (setf (cdr it) value) + (push (cons name value) + (mime-disposition-parameters part)))) + +(defmethod mime-part-file-name ((part mime-part)) + "Return the filename associated to mime PART or NIL if the mime +part doesn't have a file name." + (or (get-mime-disposition-parameter part :filename) + (get-mime-type-parameter part :name))) + +(defmethod (setf mime-part-file-name) (value (part mime-part)) + "Set the filename associated to mime PART." + (setf (get-mime-disposition-parameter part :filename) value + (get-mime-type-parameter part :name) value)) + +(defun mime-text-charset (part) + (get-mime-type-parameter part :charset)) + +(defun split-header-parts (string) + "Split parts of a MIME headers. These are divided by +semi-colons not within strings or comments." + (labels ((skip-comment (pos) + (loop + while (< pos (length string)) + do (case (elt string pos) + (#\( (setf pos (skip-comment (1+ pos)))) + (#\\ (incf pos 2)) + (#\) (return (1+ pos))) + (otherwise (incf pos))) + finally (return pos))) + (skip-string (pos) + (loop + while (< pos (length string)) + do (case (elt string pos) + (#\\ (incf pos 2)) + (#\" (return (1+ pos))) + (otherwise (incf pos))) + finally (return pos)))) + (loop + with start = 0 and i = 0 and parts = '() + while (< i (length string)) + do (case (elt string i) + (#\; (push (subseq string start i) parts) + (setf start (incf i))) + (#\" (setf i (skip-string i))) + (#\( (setf i (skip-comment (1+ i)))) + (otherwise (incf i))) + finally (return (mapcar #'string-trim-whitespace (nreverse (cons (subseq string start) parts))))))) + +(defun parse-parameter (string) + "Given a string like \"foo=bar\" return a pair (\"foo\" . +\"bar\"). Return NIL if string is not parsable." + ;; TODO(sterni): when-let + (let ((equal-position (position #\= string))) + (when equal-position + (let ((key (subseq string 0 equal-position))) + (if (= equal-position (1- (length string))) + (cons key "") + (let ((value (string-trim-whitespace (subseq string (1+ equal-position))))) + (cons key + (if (and (> (length value) 1) + (char= #\" (elt value 0))) + ;; the syntax of a RFC822 string is more or + ;; less the same as the Lisp one: use the Lisp + ;; reader + (or (ignore-errors (read-from-string value)) + (subseq value 1)) + (let ((end (or (position-if #'whitespace-p value) + (length value)))) + (subseq value 0 end)))))))))) + +(defun parse-content-type (string) + "Parse string as a Content-Type MIME header and return a list +of three elements. The first is the type, the second is the +subtype and the third is an alist of parameters and their values. +Example: (\"text\" \"plain\" ((\"charset\" . \"us-ascii\")...))." + (let* ((parts (split-header-parts string)) + (content-type-string (car parts)) + (slash (position #\/ content-type-string))) + ;; You'd be amazed to know how many MUA can't produce an RFC + ;; compliant message. + (when slash + (let ((type (subseq content-type-string 0 slash)) + (subtype (subseq content-type-string (1+ slash)))) + (list type subtype (remove nil (mapcar #'parse-parameter (cdr parts)))))))) + +(defun parse-content-disposition (string) + "Parse string as a Content-Disposition MIME header and return a +list. The first element is the layout, the other elements are +the optional parameters alist. +Example: (\"inline\" (\"filename\" . \"doggy.jpg\"))." + (let ((parts (split-header-parts string))) + (cons (car parts) (mapcan #'(lambda (parameter-string) + (awhen (parse-parameter parameter-string) + (list it))) + (cdr parts))))) + +(defun parse-RFC822-header (string) + "Parse STRING which should be a valid RFC822 message header and +return two values: a string of the header name and a string of +the header value." + (let ((colon (position #\: string))) + (when colon + (values (string-trim-whitespace (subseq string 0 colon)) + (string-trim-whitespace (subseq string (1+ colon))))))) + + +(defvar *default-type* '("text" "plain" (("charset" . "us-ascii"))) + "Internal special variable that contains the default MIME type at +any given time of the parsing phase. There are MIME container parts +that may change this.") + +(defvar *mime-types* + '((:text mime-text) + (:image mime-image) + (:audio mime-audio) + (:video mime-video) + (:application mime-application) + (:multipart mime-multipart) + (:message mime-message))) + +(defgeneric mime-part-size (part) + (:documentation + "Return the size in bytes of the body of a MIME part.")) + +(defgeneric print-mime-part (part stream) + (:documentation + "Output to STREAM one of the possible human-readable representation +of mime PART. Binary parts are omitted. This function can be used to +quote messages, for instance.")) + +(defun do-multipart-parts (body-stream part-boundary contents-function end-part-function) + "Read through BODY-STREAM. Call CONTENTS-FUNCTION at +each (non-boundary) line or END-PART-FUNCTION at each PART-BOUNDARY." + (let* ((boundary (s+ "--" part-boundary)) + (boundary-length (length boundary))) + (labels ((output-line (line) + (funcall contents-function line)) + (end-part () + (funcall end-part-function)) + (last-part () + (end-part) + (return-from do-multipart-parts)) + (process-line (line) + (cond ((not (string-starts-with boundary line)) + ;; normal line + (output-line line)) + ((and (= (length (string-trim-whitespace line)) + (+ 2 boundary-length)) + (string= "--" line :start2 boundary-length)) + ;; end of the last part + (last-part)) + ;; according to RFC2046 "the boundary may be followed + ;; by zero or more characters of linear whitespace" + ((= (length (string-trim-whitespace line)) boundary-length) + ;; beginning of the next part + (end-part)) + (t + ;; the line boundary is followed by some + ;; garbage; we treat it as a normal line + (output-line line))))) + (loop + for line = (read-line body-stream nil) + ;; we should never reach the end of a proper multipart MIME + ;; stream, but we don't want to be fooled by corrupted ones, + ;; so we check for EOF + unless line + do (last-part) + do (process-line line))))) + +(defun index-multipart-parts (body-stream part-boundary) + "Read from BODY-STREAM and return the file offset of the MIME parts +separated by PART-BOUNDARY." + (let ((parts '()) + (start 0) + (len 0) + (beginning-of-part-p t)) + (flet ((sum-chars (line) + (incf len (length line)) + ;; account for the #\newline + (if beginning-of-part-p + (setf beginning-of-part-p nil) + (incf len))) + (end-part () + (setf beginning-of-part-p t) + (push (cons start (+ start len)) parts) + (setf start (file-position body-stream) + len 0))) + (do-multipart-parts body-stream part-boundary #'sum-chars #'end-part) + ;; the first part is all the stuff up to the first boundary; + ;; just junk + (cdr (nreverse parts))))) + +(defgeneric encode-mime-part (part stream)) +(defgeneric encode-mime-body (part stream)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun write-mime-header (part stream) + (when (mime-version part) + (format stream "~&MIME-Version: ~A~%" (mime-version part))) + (format stream "~&Content-Type: ~A~:{; ~A=~S~}~%" (mime-type-string part) + (mapcar #'(lambda (pair) + (list (car pair) (cdr pair))) + (mime-type-parameters part))) + (awhen (mime-encoding part) + (format stream "Content-Transfer-Encoding: ~A~%" it)) + (awhen (mime-description part) + (format stream "Content-Description: ~A~%" it)) + (when (mime-disposition part) + (format stream "Content-Disposition: ~A~:{; ~A=~S~}~%" + (mime-disposition part) + (mapcar #'(lambda (pair) + (list (car pair) (cdr pair))) + (mime-disposition-parameters part)))) + (awhen (mime-id part) + (format stream "Content-ID: ~A~%" it)) + (terpri stream)) + +(defmethod encode-mime-part ((part mime-part) stream) + (write-mime-header part stream) + (encode-mime-body part stream)) + +(defmethod encode-mime-part ((part mime-message) stream) + ;; tricky: we have to mix the MIME headers with the message headers + (dolist (h (mime-message-headers part)) + (unless (stringp (car h)) + (setf (car h) + (string-capitalize (car h)))) + (unless (or (string-starts-with "content-" (car h) #'string-equal) + (string-equal "mime-version" (car h))) + (format stream "~A: ~A~%" + (car h) (cdr h)))) + (encode-mime-part (mime-body part) stream)) + +(defmethod encode-mime-part ((part mime-multipart) stream) + ;; choose a boundary if not already set + (let* ((original-boundary (get-mime-type-parameter part :boundary)) + (boundary (choose-boundary (mime-parts part) original-boundary))) + (unless (and original-boundary + (string= boundary original-boundary)) + (setf (get-mime-type-parameter part :boundary) boundary)) + (call-next-method))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod encode-mime-body ((part mime-part) stream) + (with-input-from-mime-body-stream (in part) + (encode-stream in stream (mime-encoding part)))) + +(defmethod encode-mime-body ((part mime-message) stream) + (encode-mime-body (mime-body part) stream)) + +(defmethod encode-mime-body ((part mime-multipart) stream) + (let ((boundary (or (get-mime-type-parameter part :boundary) + (setf (get-mime-type-parameter part :boundary) + (choose-boundary (mime-parts part)))))) + (dolist (p (mime-parts part)) + (format stream "~%--~A~%" boundary) + (encode-mime-part p stream)) + (format stream "~%--~A--~%" boundary))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun time-RFC822-string (&optional (epoch (get-universal-time))) + "Return a string describing the current time according to +the RFC822." + (multiple-value-bind (ss mm hh day month year week-day dst tz) (decode-universal-time epoch) + (declare (ignore dst)) + (format nil "~A, ~A ~A ~2,'0D ~2,'0D:~2,'0D:~2,'0D ~:[-~;+~]~2,'0D~2,'0D" + (subseq (week-day->string week-day) 0 3) + day (subseq (month->string month) 0 3) (mod year 100) hh mm ss + (plusp tz) (abs (truncate tz)) (mod (* 60 tz) 60)))) + +(defun parse-RFC822-date (date-string) + "Parse a RFC822 compliant date string and return an universal +time." + ;; if we can't parse it, just return NIL + (ignore-errors + ;; skip the optional DoW + (awhen (position #\, date-string) + (setf date-string (subseq date-string (1+ it)))) + (destructuring-bind (day month year time &optional tz &rest rubbish) + (split-at '(#\space #\tab) date-string) + (declare (ignore rubbish)) + (destructuring-bind (hh mm &optional ss) (split-string-at-char time #\:) + (encode-universal-time + (if ss + (read-from-string ss) + 0) + (read-from-string mm) + (read-from-string hh) + (read-from-string day) + (1+ (position month + '("Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :test #'string-equal)) + (read-from-string year) + (when (and tz (or (char= #\+ (elt tz 0)) + (char= #\- (elt tz 0)))) + (/ (read-from-string tz) 100))))))) + +(defun read-RFC822-headers (stream &optional required-headers) + "Read RFC822 compliant headers from STREAM and return them in a +alist of keyword and string pairs. REQUIRED-HEADERS is a list of +header names we are interested in; if NIL return all headers +found in STREAM." + ;; the skip-header variable is to avoid the mistake of appending a + ;; continuation line of a header we don't want to a header we want + (loop + with headers = '() and skip-header = nil + for line = (let ((line (read-line stream nil))) + ;; skip the Unix "From " header if present + (if (string-starts-with "From " line) + (read-line stream nil) + line)) + then (read-line stream nil) + while (and line + (not (zerop (length line)))) + do (if (whitespace-p (elt line 0)) + (unless (or skip-header + (null headers)) + (setf (cdar headers) (s+ (cdar headers) '(#\newline) line))) + (multiple-value-bind (name value) (parse-RFC822-header line) + ;; the line contained rubbish instead of an header: we + ;; play nice and return as we were at the end of the + ;; headers + (unless name + (return (nreverse headers))) + (if (or (null required-headers) + (member name required-headers :test #'string-equal)) + (progn + (push (cons name value) headers) + (setf skip-header nil)) + (setf skip-header t)))) + finally (return (nreverse headers)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric mime-message (thing) + (:documentation + "Convert THING to a MIME-MESSAGE object.")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun mime-message-header-values (name message &key decode) + "Return all values of the header with NAME in MESSAGE, optionally decoding + it according to RFC2047 if :DECODE is T." + (loop ;; A header may occur multiple times + for header in (mime-message-headers message) + ;; MIME Headers should be case insensitive + ;; https://stackoverflow.com/a/6143644 + when (string-equal (car header) name) + collect (if decode + (decode-RFC2047 (cdr header)) + (cdr header)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *lazy-mime-decode* t + "If true don't decode mime bodies in memory.") + +(defgeneric decode-mime-body (part input-stream)) + +(defmethod decode-mime-body ((part mime-part) (stream flexi-stream)) + (let ((base (flexi-stream-root-stream stream))) + (if *lazy-mime-decode* + (setf (mime-body part) + (make-file-portion :data (etypecase base + (vector-stream + (flexi-streams::vector-stream-vector base)) + (file-stream + (pathname base))) + :encoding (mime-encoding part) + :start (flexi-stream-position stream) + :end (flexi-stream-bound stream))) + (call-next-method)))) + +(defmethod decode-mime-body ((part mime-part) (stream file-stream)) + (if *lazy-mime-decode* + (setf (mime-body part) + (make-file-portion :data (pathname stream) + :encoding (mime-encoding part) + :start (file-position stream))) + (call-next-method))) + +(defmethod decode-mime-body ((part mime-part) (stream vector-stream)) + (if *lazy-mime-decode* + (setf (mime-body part) + (make-file-portion :data (flexi-streams::vector-stream-vector stream) + :encoding (mime-encoding part) + :start (flexi-streams::vector-stream-index stream))) + (call-next-method))) + +(defmethod decode-mime-body ((part mime-part) stream) + (setf (mime-body part) + (decode-stream-to-sequence stream (mime-encoding part)))) + +(defmethod decode-mime-body ((part mime-multipart) stream) + "Decode STREAM according to PART characteristics and return a +list of MIME parts." + (save-file-excursion (stream) + (let ((offsets (index-multipart-parts stream (get-mime-type-parameter part :boundary)))) + (setf (mime-parts part) + (mapcar #'(lambda (p) + (destructuring-bind (start . end) p + (let ((*default-type* (if (eq :digest (mime-subtype part)) + '("message" "rfc822" ()) + '("text" "plain" (("charset" . "us-ascii"))))) + (in (make-positioned-flexi-input-stream stream + :position start + :bound end + :ignore-close t))) + (read-mime-part in)))) + offsets))))) + +(defmethod decode-mime-body ((part mime-message) stream) + "Read from STREAM the body of PART. Return the decoded MIME +body." + (setf (mime-body part) + (read-mime-message stream))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64) + "List of known content encodings.") + +(defun keywordify-encoding (string) + "Return a keyword for a content transfer encoding string. +Return STRING itself if STRING is an unkown encoding." + (aif (member string +known-encodings+ :test #'string-equal) + (car it) + string)) + +(defun header (name headers) + (let ((elt (assoc name headers :test #'string-equal))) + (values (cdr elt) (car elt)))) + +(defun (setf header) (value name headers) + (let ((entry (assoc name headers :test #'string-equal))) + (unless entry + (error "missing header ~A can't be set" name)) + (setf (cdr entry) value))) + +(defun make-mime-part (headers stream) + "Create a MIME-PART object based on HEADERS and a body which +has to be read from STREAM. If the mime part type can't be +guessed from the headers, use the *DEFAULT-TYPE*." + (flet ((hdr (what) + (header what headers))) + (destructuring-bind (type subtype parms) + (or + (aand (hdr :content-type) + (parse-content-type it)) + *default-type*) + (let* ((class (or (cadr (assoc type *mime-types* :test #'string-equal)) + 'mime-unknown-part)) + (disp (aif (hdr :content-disposition) + (parse-content-disposition it) + (values nil nil))) + (part (make-instance class + :type (hdr :content-type) + :subtype subtype + :type-parameters parms + :disposition (car disp) + :disposition-parameters (cdr disp) + :mime-version (hdr :mime-version) + :encoding (keywordify-encoding + (hdr :content-transfer-encoding)) + :description (hdr :content-description) + :id (hdr :content-id) + :allow-other-keys t))) + (decode-mime-body part stream) + part)))) + +(defun read-mime-part (stream) + "Read mime part from STREAM. Return a MIME-PART object." + (let ((headers (read-rfc822-headers stream + '(:mime-version :content-transfer-encoding :content-type + :content-disposition :content-description :content-id)))) + (make-mime-part headers stream))) + +(defun read-mime-message (stream) + "Main function to read a MIME message from a stream. It +returns a MIME-MESSAGE object." + (let ((headers (read-rfc822-headers stream)) + (*default-type* '("text" "plain" (("charset" . "us-ascii"))))) + (flet ((hdr (what) + (header what headers))) + (destructuring-bind (type subtype parms) + (or (aand (hdr :content-type) + (parse-content-type it)) + *default-type*) + (declare (ignore type subtype)) + (make-instance 'mime-message + :headers headers + ;; this is just for easy access + :type-parameters parms + :body (make-mime-part headers stream)))))) + +(defmethod mime-message ((msg mime-message)) + msg) + +(defmethod mime-message ((msg string)) + (mime-message (flexi-streams:string-to-octets msg))) + +(defmethod mime-message ((msg vector)) + (with-input-from-sequence (in msg) + (mime-message in))) + +(defmethod mime-message ((msg pathname)) + (with-open-file (in msg :element-type '(unsigned-byte 8)) + (mime-message in))) + +(defmethod mime-message ((msg flexi-stream)) + (read-mime-message msg)) + +(defmethod mime-message ((msg stream)) + (read-mime-message (make-flexi-stream msg))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric mime-part (object) + (:documentation + "Promote object, if necessary, to MIME-PART.")) + +(defmethod mime-part ((object string)) + (make-instance 'mime-text :subtype "plain" :body object)) + +(defmethod mime-part ((object pathname)) + (make-instance 'mime-application + :subtype "octect-stream" + :content-transfer-encoding :base64 + :body (read-file object :element-type '(unsigned-byte 8)))) + +(defmethod mime-part ((object mime-part)) + object) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod make-encoded-body-stream ((part mime-bodily-part)) + (let ((body (mime-body part))) + (make-instance (case (mime-encoding part) + (:base64 + 'base64-encoder-input-stream) + (:quoted-printable + 'quoted-printable-encoder-input-stream) + (otherwise + '8bit-encoder-input-stream)) + :underlying-stream + (make-input-adapter body)))) + +(defun choose-boundary (parts &optional default) + (labels ((match-in-parts (boundary parts) + (loop + for p in parts + thereis (typecase p + (mime-multipart + (match-in-parts boundary (mime-parts p))) + (mime-bodily-part + (match-in-body p boundary))))) + (match-in-body (part boundary) + (with-open-stream (in (make-encoded-body-stream part)) + (loop + for line = (read-line in nil) + while line + when (string= line boundary) + return t + finally (return nil))))) + (do ((boundary (if default + (format nil "--~A" default) + #1=(format nil "--~{~36R~}" + (loop + for i from 0 below 20 + collect (random 36)))) + #1#)) + ((not (match-in-parts boundary parts)) (subseq boundary 2))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; fall back method +(defmethod mime-part-size ((part mime-part)) + (let ((body (mime-body part))) + (typecase body + (pathname + (file-size body)) + (string + (length body)) + (vector + (length body)) + (t nil)))) + +(defmethod mime-part-size ((part mime-multipart)) + (loop + for p in (mime-parts part) + for size = (mime-part-size p) + unless size + return nil + sum size)) + +(defmethod mime-part-size ((part mime-message)) + (mime-part-size (mime-body part))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod print-mime-part ((part mime-multipart) (out stream)) + (case (mime-subtype part) + (:alternative + ;; try to choose something simple to print or the first thing + (let ((parts (mime-parts part))) + (print-mime-part (or (find-if #'(lambda (part) + (and (eq (class-of part) (find-class 'mime-text)) + (eq (mime-subtype part) :plain))) + parts) + (car parts)) out))) + (otherwise + (dolist (subpart (mime-parts part)) + (print-mime-part subpart out))))) + +;; This is WRONG. Here we don't use any special character encoding +;; because we don't know which one we should use. Messages written in +;; anything but ASCII will likely be unreadable -wcp11/10/07. +(defmethod print-mime-part ((part mime-text) (out stream)) + (let ((body (mime-body part))) + (etypecase body + (string + (write-string body out)) + (vector + (loop + for byte across body + do (write-char (code-char byte) out))) + (pathname + (with-open-file (in body) + (loop + for c = (read-char in nil) + while c + do (write-char c out))))))) + +(defmethod print-mime-part ((part mime-message) (out stream)) + (flet ((hdr (name) + (multiple-value-bind (value tag) + (header name (mime-message-headers part)) + (cons tag value)))) + (dolist (h (mapcar #'hdr '("from" "subject" "to" "date" "x-march-archive-id"))) + (when h + (format out "~&~A: ~A" (car h) (cdr h)))) + (format out "~2%") + (print-mime-part (mime-body part) out))) + +(defmethod print-mime-part ((part mime-part) (out stream)) + (format out "~&[ ~A subtype=~A ~@[description=~S ~]~@[size=~A~] ]~%" + (type-of part) (mime-subtype part) (mime-description part) (mime-part-size part))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric find-mime-part-by-path (mime path) + (:documentation + "Return a subpart of MIME identified by PATH, which is a list of +integers. For example '(2 3 1) is the first part of the third of the +second in MIME.")) + +(defmethod find-mime-part-by-path ((part mime-part) path) + (if (null path) + part + (error "~S doesn't have subparts" part))) + +(defmethod find-mime-part-by-path ((part mime-message) path) + (if (null path) + part + (if (= 1 (car path)) + (find-mime-part-by-path (mime-body part) (cdr path)) + (error "~S may have just one subpart, but part ~D was requested (parts are enumerated base 1)." + part (car path))))) + +(defmethod find-mime-part-by-path ((part mime-multipart) path) + (if (null path) + part + (let ((parts (mime-parts part)) + (part-number (car path))) + (if (<= 1 part-number (length parts)) + (find-mime-part-by-path (nth (1- (car path)) (mime-parts part)) (cdr path)) + (error "~S has just ~D subparts, but part ~D was requested (parts are enumerated base 1)." + part (length parts) part-number))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric find-mime-part-by-id (part id) + (:documentation + "Return a subpart of PAR, whose Content-ID is the same as ID, which +is a string.")) + +(defmethod find-mime-part-by-id ((part mime-part) id) + (when (string= id (mime-id part)) + part)) + +(defmethod find-mime-part-by-id ((part mime-message) id) + (find-mime-part-by-id (mime-body part) id)) + +(defmethod find-mime-part-by-id ((part mime-multipart) id) + (or (call-next-method) + (some #'(lambda (p) + (find-mime-part-by-id p id)) + (mime-parts part)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric find-mime-text-part (msg) + (:documentation + "Return message if it is a text message or first text part. + If no suitable text part is found, return NIL.")) + +(defmethod find-mime-text-part ((part mime-text)) + part) ; found our target + +(defmethod find-mime-text-part ((msg mime-message)) + ;; mime-body is either a mime-part or mime-multipart + (find-mime-text-part (mime-body msg))) + +(defmethod find-mime-text-part ((parts mime-multipart)) + ;; multipart messages may have a body, otherwise we + ;; search for the first text part + (or (call-next-method) + (find-if #'find-mime-text-part (mime-parts parts)))) + +(defmethod find-mime-text-part ((part mime-part)) + nil) ; default case + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric mime-type-string (mime-part) + (:documentation + "Return the string describing the MIME part.")) + +(defmethod mime-type-string ((part mime-unknown-part)) + (mime-type part)) + +(defmethod mime-type-string ((part mime-text)) + (format nil "text/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-image)) + (format nil "image/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-audio)) + (format nil "audio/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-video)) + (format nil "video/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-application)) + (format nil "application/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-multipart)) + (format nil "multipart/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-message)) + (format nil "message/~A" (mime-subtype part))) + +(defmethod mime-type-string ((part mime-unknown-part)) + (mime-type part)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric map-parts (function mime-part) + (:documentation + "Recursively map FUNCTION to MIME-PART or its components.")) + +;; Here we wrongly assume that we'll never want to replace messages +;; and multiparts altogether. If you need to do so you have to write +;; your own mapping functions. + +(defmethod map-parts ((function function) (part mime-part)) + (funcall function part)) + +(defmethod map-parts ((function function) (part mime-message)) + (setf (mime-body part) (map-parts function (mime-body part))) + part) + +(defmethod map-parts ((function function) (part mime-multipart)) + (setf (mime-parts part) (mapcar #'(lambda (p) + (map-parts function p)) + (mime-parts part))) + part) + +;; apply-on-parts is like map-parts but doesn't modify the parts (at least +;; not implicitly) + +(defgeneric apply-on-parts (function part)) + +(defmethod apply-on-parts ((function function) (part mime-part)) + (funcall function part)) + +(defmethod apply-on-parts ((function function) (part mime-multipart)) + (dolist (p (mime-parts part)) + (apply-on-parts function p))) + +(defmethod apply-on-parts ((function function) (part mime-message)) + (apply-on-parts function (mime-body part))) + +(defmacro do-parts ((var mime-part) &body body) + `(apply-on-parts #'(lambda (,var) ,@body) ,mime-part)) diff --git a/third_party/lisp/mime4cl/mime4cl-tests.asd b/third_party/lisp/mime4cl/mime4cl-tests.asd new file mode 100644 index 0000000000..f3b429eafb --- /dev/null +++ b/third_party/lisp/mime4cl/mime4cl-tests.asd @@ -0,0 +1,55 @@ +;;; mime4cl-tests.asd --- system description for the regression tests + +;;; Copyright (C) 2006, 2007, 2010 by Walter C. Pelissero +;;; Copyright (C) 2022 by The TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +#-(or sbcl) +(warn "This code hasn't been tested on your Lisp system.") + +(defpackage :mime4cl-tests-system + (:use :common-lisp :asdf #+asdfa :asdfa) + (:export #:*base-directory* + #:*compilation-epoch*)) + +(in-package :mime4cl-tests-system) + +(defsystem mime4cl-tests + :name "MIME4CL-tests" + :author "Walter C. Pelissero <walter@pelissero.de>" + :maintainer "Walter C. Pelissero <walter@pelissero.de>" + :description "Test suite for the MIME4CL library" + :long-description + "These regression tests require rt.lisp from MIT. It is included." + :licence "LGPL" + :depends-on (:mime4cl) + :components + ((:module test + :components + ((:file "rt") + (:file "package" :depends-on ("rt")) + (:file "endec" :depends-on ("rt" "package")) + (:file "address" :depends-on ("rt" "package")) + (:file "mime" :depends-on ("rt" "package")))))) + +;; when loading this form the regression-test, the package is yet to +;; be loaded so we cannot use rt:do-tests directly or we would get a +;; reader error (unknown package) +(defmethod perform ((o test-op) (c (eql (find-system :mime4cl-tests)))) + (or (funcall (intern "DO-TESTS" "REGRESSION-TEST")) + (error "test-op failed"))) diff --git a/third_party/lisp/mime4cl/mime4cl.asd b/third_party/lisp/mime4cl/mime4cl.asd new file mode 100644 index 0000000000..6528f115d4 --- /dev/null +++ b/third_party/lisp/mime4cl/mime4cl.asd @@ -0,0 +1,49 @@ +;;; mime4cl.asd --- system definition + +;;; Copyright (C) 2005-2007, 2010 by Walter C. Pelissero +;;; Copyright (C) 2022 by The TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 2, or (at +;;; your option) any later version. +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; You should have received a copy of the GNU General Public License +;;; along with this program; see the file COPYING. If not, write to +;;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307, USA. + +(in-package :cl-user) + +(defpackage :mime4cl-system + (:use :common-lisp :asdf)) + +(in-package :mime4cl-system) + +(defsystem mime4cl + :name "MIME4CL" + :author "Walter C. Pelissero <walter@pelissero.de>" + :maintainer "Walter C. Pelissero <walter@pelissero.de>" + ;; :version "0.0" + :description "MIME primitives for Common Lisp" + :long-description + "A collection of Common Lisp primitives to forge and handle +MIME mail contents." + :licence "LGPL" + :depends-on (:npg :sclf :trivial-gray-streams) + :components + ((:file "package") + (:file "mime" :depends-on ("package" "endec" "streams")) + (:file "endec" :depends-on ("package")) + (:file "streams" :depends-on ("package" "endec")) + (:file "address" :depends-on ("package")))) + +(defmethod perform ((o test-op) (c (eql (find-system 'mime4cl)))) + (oos 'load-op 'mime4cl-tests) + (oos 'test-op 'mime4cl-tests :force t)) diff --git a/third_party/lisp/mime4cl/package.lisp b/third_party/lisp/mime4cl/package.lisp new file mode 100644 index 0000000000..94b9e6b390 --- /dev/null +++ b/third_party/lisp/mime4cl/package.lisp @@ -0,0 +1,103 @@ +;;; package.lisp --- package declaration + +;;; Copyright (C) 2005-2007, 2010 by Walter C. Pelissero +;;; Copyright (C) 2022 The TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :cl-user) + +(defpackage :mime4cl + (:nicknames :mime) + (:use :common-lisp :npg :mime4cl-ex-sclf :trivial-gray-streams :flexi-streams) + (:export #:*lazy-mime-decode* + #:print-mime-part + #:read-mime-message + #:mime-part + #:mime-text + #:mime-binary + #:mime-id + #:mime-image + #:mime-message + #:mime-multipart + #:mime-audio + #:mime-unknown-part + #:get-mime-disposition-parameter + #:get-mime-type-parameter + #:mime-disposition + #:mime-disposition-parameters + #:mime-encoding + #:mime-application + #:mime-video + #:mime-description + #:mime-part-size + #:mime-subtype + #:mime-body + #:mime-body-stream + #:mime-body-length + #:mime-parts + #:mime-part-p + #:mime-type + #:mime-type-string + #:mime-type-parameters + #:mime-message-headers + #:mime-message-header-values + #:mime= + #:find-mime-part-by-path + #:find-mime-part-by-id + #:find-mime-text-part + #:encode-mime-part + #:encode-mime-body + #:decode-quoted-printable-stream + #:decode-quoted-printable-string + #:encode-quoted-printable-stream + #:encode-quoted-printable-sequence + #:encode-base64-stream + #:encode-base64-sequence + #:parse-RFC2047-text + #:decode-RFC2047 + #:parse-RFC822-header + #:read-RFC822-headers + #:time-RFC822-string + #:parse-RFC822-date + #:map-parts + #:do-parts + #:apply-on-parts + #:mime-part-file-name + #:mime-text-charset + #:with-input-from-mime-body-stream + ;; endec.lisp + #:base64-encoder + #:null-encoder + #:null-decoder + #:byte-encoder + #:byte-decoder + #:quoted-printable-encoder + #:quoted-printable-decoder + #:encoder-write-byte + #:encoder-finish-output + #:decoder-read-byte + #:decoder-read-sequence + #:*base64-line-length* + #:*quoted-printable-line-length* + ;; address.lisp + #:parse-addresses #:mailboxes-only + #:mailbox #:mbx-description #:mbx-user #:mbx-host #:mbx-domain #:mbx-domain-name #:mbx-address + #:mailbox-group #:mbxg-name #:mbxg-mailboxes + ;; streams.lisp + #:redirect-stream + )) diff --git a/third_party/lisp/mime4cl/streams.lisp b/third_party/lisp/mime4cl/streams.lisp new file mode 100644 index 0000000000..71a32d84e4 --- /dev/null +++ b/third_party/lisp/mime4cl/streams.lisp @@ -0,0 +1,274 @@ +;;; streams.lisp --- En/De-coding Streams + +;;; Copyright (C) 2012 by Walter C. Pelissero +;;; Copyright (C) 2021-2023 by the TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :mime4cl) + +(defun flexi-stream-root-stream (stream) + "Return the non FLEXI-STREAM stream a given chain of FLEXI-STREAMs is based on." + (if (typep stream 'flexi-stream) + (flexi-stream-root-stream (flexi-stream-stream stream)) + stream)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass coder-stream-mixin () + ((real-stream :type stream + :initarg :underlying-stream + :reader real-stream) + (dont-close :initform nil + :initarg :dont-close))) + +(defmethod stream-file-position ((stream coder-stream-mixin)) + (file-position (slot-value stream 'real-stream))) + +(defmethod (setf stream-file-position) (newval (stream coder-stream-mixin)) + (file-position (slot-value stream 'real-stream) newval)) + +(defclass coder-input-stream-mixin (fundamental-binary-input-stream coder-stream-mixin) + ()) +(defclass coder-output-stream-mixin (fundamental-binary-output-stream coder-stream-mixin) + ()) + +;; TODO(sterni): temporary, ugly measure to make flexi-streams happy +(defmethod stream-element-type ((stream coder-input-stream-mixin)) + (declare (ignore stream)) + '(unsigned-byte 8)) + +(defclass quoted-printable-decoder-stream (coder-input-stream-mixin quoted-printable-decoder) ()) +(defclass 8bit-decoder-stream (coder-input-stream-mixin 8bit-decoder) ()) + +(defclass quoted-printable-encoder-stream (coder-output-stream-mixin quoted-printable-encoder) ()) +(defclass base64-encoder-stream (coder-output-stream-mixin base64-encoder) ()) +(defclass 8bit-encoder-stream (coder-output-stream-mixin 8bit-encoder) ()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod initialize-instance :after ((stream coder-stream-mixin) &key &allow-other-keys) + (unless (slot-boundp stream 'real-stream) + (error "REAL-STREAM is unbound. Must provide a :UNDERLYING-STREAM argument."))) + +(defmethod initialize-instance ((stream coder-output-stream-mixin) &key &allow-other-keys) + (call-next-method) + (unless (slot-boundp stream 'output-function) + (setf (slot-value stream 'output-function) + #'(lambda (char) + (write-char char (slot-value stream 'real-stream)))))) + +(defmethod initialize-instance ((stream coder-input-stream-mixin) &key &allow-other-keys) + (call-next-method) + (unless (slot-boundp stream 'input-function) + (setf (slot-value stream 'input-function) + #'(lambda () + (read-char (slot-value stream 'real-stream) nil))))) + +(defmethod stream-read-byte ((stream coder-input-stream-mixin)) + (or (decoder-read-byte stream) + :eof)) + +(defmethod stream-write-byte ((stream coder-output-stream-mixin) byte) + (encoder-write-byte stream byte)) + +(defmethod close ((stream coder-stream-mixin) &key abort) + (with-slots (real-stream dont-close) stream + (unless dont-close + (close real-stream :abort abort)))) + +(defmethod close ((stream coder-output-stream-mixin) &key abort) + (unless abort + (encoder-finish-output stream)) + (call-next-method)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass encoder-input-stream (fundamental-character-input-stream coder-stream-mixin) + ((encoder) + (buffer-queue :initform (make-queue))) + (:documentation + "This is the base class for encoders with the direction swapped. It +reads from REAL-STREAM a stream of bytes, encodes it and returnes it +in a stream of character.")) + +(defclass quoted-printable-encoder-input-stream (encoder-input-stream) ()) +(defclass base64-encoder-input-stream (encoder-input-stream) ()) +(defclass 8bit-encoder-input-stream (fundamental-character-input-stream coder-stream-mixin) ()) + +(defmethod initialize-instance ((stream quoted-printable-encoder-input-stream) &key &allow-other-keys) + (call-next-method) + (with-slots (encoder buffer-queue) stream + (setf encoder + (make-instance 'quoted-printable-encoder + :output-function #'(lambda (char) + (queue-append buffer-queue char)))))) + +(defmethod initialize-instance ((stream base64-encoder-input-stream) &key &allow-other-keys) + (call-next-method) + (with-slots (encoder buffer-queue) stream + (setf encoder + (make-instance 'base64-encoder + :output-function #'(lambda (char) + (queue-append buffer-queue char)))))) + +(defmethod stream-read-char ((stream encoder-input-stream)) + (with-slots (encoder buffer-queue real-stream) stream + (loop + while (queue-empty-p buffer-queue) + do (let ((byte (read-byte real-stream nil))) + (if byte + (encoder-write-byte encoder byte) + (progn + (encoder-finish-output encoder) + (queue-append buffer-queue :eof))))) + (queue-pop buffer-queue))) + + +(defmethod stream-read-char ((stream 8bit-encoder-input-stream)) + (with-slots (real-stream) stream + (aif (read-byte real-stream nil) + (code-char it) + :eof))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun make-custom-flexi-stream (class stream other-args) + (apply #'make-instance + class + :stream stream + (mapcar (lambda (x) + ;; make-flexi-stream has a discrepancy between :initarg of + ;; make-instance and its &key which we mirror here. + (if (eq x :external-format) :flexi-stream-external-format x)) + other-args))) + +(defclass adapter-flexi-input-stream (flexi-input-stream) + ((ignore-close + :initform nil + :initarg :ignore-close + :documentation + "If T, calling CLOSE on the stream does nothing. +If NIL, the underlying stream is closed.")) + (:documentation "FLEXI-STREAM that does not close the underlying stream on +CLOSE if :IGNORE-CLOSE is T.")) + +(defmethod close ((stream adapter-flexi-input-stream) &key abort) + (declare (ignore abort)) + (with-slots (ignore-close) stream + (unless ignore-close + (call-next-method)))) + +(defun make-input-adapter (source) + (etypecase source + ;; If it's already a stream, we need to make sure it's not closed by the adapter + (stream + (assert (input-stream-p source)) + (if (and (typep source 'adapter-flexi-input-stream) + (slot-value source 'ignore-close)) + source ; already ignores CLOSE + (make-adapter-flexi-input-stream source :ignore-close t))) + ;; TODO(sterni): is this necessary? (maybe with (not *lazy-mime-decode*)?) + (string + (make-input-adapter (string-to-octets source))) + ((vector (unsigned-byte 8)) + (make-in-memory-input-stream source)) + (pathname + (make-flexi-stream (open source :element-type '(unsigned-byte 8)))) + (file-portion + (open-decoded-file-portion source)))) + +(defun make-adapter-flexi-input-stream (stream &rest args) + "Create a ADAPTER-FLEXI-INPUT-STREAM. Accepts the same keyword arguments as +MAKE-FLEXI-STREAM as well as :IGNORE-CLOSE. If T, the underlying stream is not +closed." + (make-custom-flexi-stream 'adapter-flexi-input-stream stream args)) + +(defclass positioned-flexi-input-stream (adapter-flexi-input-stream) + () + (:documentation + "FLEXI-INPUT-STREAM that automatically advances the underlying :STREAM to +the location given by :POSITION. This uses FILE-POSITION internally, so it'll +only works if the underlying stream position is tracked in bytes. Note that +the underlying stream is still advanced, so having multiple instances of +POSITIONED-FLEXI-INPUT-STREAM based with the same underlying stream won't work +reliably. +Also supports :IGNORE-CLOSE of ADAPTER-FLEXI-INPUT-STREAM.")) + +(defmethod initialize-instance ((stream positioned-flexi-input-stream) + &key &allow-other-keys) + (call-next-method) + ;; The :POSITION initarg is only informational for flexi-streams: It assumes + ;; it is were the stream it got is already at and continuously updates it + ;; for querying (via FLEXI-STREAM-POSITION) and bound checking. + ;; Since we have streams that are not positioned correctly, we need to do this + ;; here using FILE-POSITION. Note that assumes the underlying implementation + ;; uses bytes for FILE-POSITION which is not guaranteed (probably some streams + ;; even in SBCL don't). + (file-position (flexi-stream-stream stream) (flexi-stream-position stream))) + +(defun make-positioned-flexi-input-stream (stream &rest args) + "Create a POSITIONED-FLEXI-INPUT-STREAM. Accepts the same keyword arguments as +MAKE-FLEXI-STREAM as well as :IGNORE-CLOSE. Causes the FILE-POSITION of STREAM to +be modified to match the :POSITION argument." + (make-custom-flexi-stream 'positioned-flexi-input-stream stream args)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; TODO(sterni): test correct behavior with END NIL +(defstruct file-portion + data ; string or a pathname + encoding + start + end) + +(defun open-decoded-file-portion (file-portion) + (with-slots (data encoding start end) + file-portion + (let* ((binary-stream + (etypecase data + (pathname + (open data :element-type '(unsigned-byte 8))) + ((vector (unsigned-byte 8)) + (flexi-streams:make-in-memory-input-stream data)) + (stream + ;; TODO(sterni): assert that bytes/flexi-stream + data))) + (params (ccase encoding + ((:quoted-printable :base64) '(:external-format :us-ascii)) + (:8bit '(:element-type (unsigned-byte 8))) + (:7bit '(:external-format :us-ascii)))) + (portion-stream (apply #'make-positioned-flexi-input-stream + binary-stream + :position start + :bound end + ;; if data is a stream we can't have a + ;; FILE-PORTION without modifying it when + ;; reading etc. The least we can do, though, + ;; is forgo destroying it. + :ignore-close (typep data 'stream) + params)) + (needs-decoder-stream (member encoding '(:quoted-printable + :base64)))) + + (if needs-decoder-stream + (make-instance + (ccase encoding + (:quoted-printable 'quoted-printable-decoder-stream) + (:base64 'qbase64:decode-stream)) + :underlying-stream portion-stream) + portion-stream)))) diff --git a/third_party/lisp/mime4cl/test/address.lisp b/third_party/lisp/mime4cl/test/address.lisp new file mode 100644 index 0000000000..a3653985c4 --- /dev/null +++ b/third_party/lisp/mime4cl/test/address.lisp @@ -0,0 +1,123 @@ +;;; address.lisp --- tests for the e-mail address parser + +;;; Copyright (C) 2007, 2009 by Walter C. Pelissero +;;; Copyright (C) 2022 by The TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :mime4cl-tests) + +(defun test-parsing (string) + (format nil "~{~A~^, ~}" (parse-addresses string))) + +(deftest address-parse-simple.1 + (test-parsing "foo@bar") + "foo@bar") + +(deftest address-parse-simple.2 + (test-parsing "foo@bar.com") + "foo@bar.com") + +(deftest address-parse-simple.3 + (test-parsing "foo@bar.baz.com") + "foo@bar.baz.com") + +(deftest address-parse-simple.4 + (test-parsing "foo.ooo@bar.baz.com") + "foo.ooo@bar.baz.com") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest address-parse-simple-commented.1 + (test-parsing "foo@bar (Some Comment)") + "\"Some Comment\" <foo@bar>") + +(deftest address-parse-simple-commented.2 + (test-parsing "foo@bar (Some, Comment)") + "\"Some, Comment\" <foo@bar>") + +(deftest address-parse-simple-commented.3 + (test-parsing "foo@bar (Some Comment (yes, indeed))") + "\"Some Comment (yes, indeed)\" <foo@bar>") + +(deftest address-parse-simple-commented.4 + (test-parsing "foo.bar@host.complicated.domain.net (Some Comment (yes, indeed))") + "\"Some Comment (yes, indeed)\" <foo.bar@host.complicated.domain.net>") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest address-parse-angle.1 + (test-parsing "<foo@bar.baz.net>") + "foo@bar.baz.net") + +(deftest address-parse-angle.2 + (test-parsing "My far far friend <foo@bar.baz.net>") + "\"My far far friend\" <foo@bar.baz.net>") + +(deftest address-parse-angle.3 + (test-parsing "\"someone, I don't like\" <foo@bar.baz.net>") + "\"someone, I don't like\" <foo@bar.baz.net>") + +(deftest address-parse-angle.4 + (test-parsing "\"this could (be a comment)\" <foo@bar.net>") + "\"this could (be a comment)\" <foo@bar.net>") + +(deftest address-parse-angle.5 + (test-parsing "don't be fooled <foo@bar.net>") + "\"don't be fooled\" <foo@bar.net>") + +(deftest address-parse-angle.6 + (test-parsing "<foo@bar>") + "foo@bar") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest address-parse-domain-literal.1 + (test-parsing "<foo@[bar]>") + "foo@[bar]") + +(deftest address-parse-domain-literal.2 + (test-parsing "<foo@[bar.net]>") + "foo@[bar.net]") + +(deftest address-parse-domain-literal.3 + (test-parsing "<foo@[10.0.0.2]>") + "foo@[10.0.0.2]") + +(deftest address-parse-domain-literal.4 + (test-parsing "<foo.bar@[10.0.0.2]>") + "foo.bar@[10.0.0.2]") + +(deftest address-parse-domain-literal.5 + (test-parsing "somewhere unkown <foo.bar@[10.0.0.2]>") + "\"somewhere unkown\" <foo.bar@[10.0.0.2]>") + +(deftest address-parse-domain-literal.6 + (test-parsing "\"Some--One\" <foo.bar@[10.0.0.23]>") + "\"Some--One\" <foo.bar@[10.0.0.23]>") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest address-parse-group.1 + (test-parsing "friends:john@bar.in.soho, jack@pub.round.the.corner, jim@[10.0.1.2];") + "friends: john@bar.in.soho, jack@pub.round.the.corner, jim@[10.0.1.2];") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest address-parse-mixed.1 + (test-parsing "Foo BAR <foo@bar.com>, \"John, Smith (that one!)\" <john.smith@host.domain.org>, friends:john@bar,jack@pub;, foo.bar.baz@wow.mail.mine, dont.bark@me (Fierce Dog)") + "\"Foo BAR\" <foo@bar.com>, \"John, Smith (that one!)\" <john.smith@host.domain.org>, friends: john@bar, jack@pub;, foo.bar.baz@wow.mail.mine, \"Fierce Dog\" <dont.bark@me>") diff --git a/third_party/lisp/mime4cl/test/endec.lisp b/third_party/lisp/mime4cl/test/endec.lisp new file mode 100644 index 0000000000..6b22b3f6a2 --- /dev/null +++ b/third_party/lisp/mime4cl/test/endec.lisp @@ -0,0 +1,184 @@ +;;; endec.lisp --- test suite for the MIME encoder/decoder functions + +;;; Copyright (C) 2006, 2007, 2009, 2010 by Walter C. Pelissero +;;; Copyright (C) 2022 by The TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :mime4cl-tests) + +(deftest quoted-printable.1 + (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code + "Français, Español, böse, skøl")) + "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l") + +(deftest quoted-printable.2 + (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code + "Français, Español, böse, skøl") + :start 10 :end 17) + "Espa=F1ol") + +(deftest quoted-printable.3 + (map 'string #'code-char + (decode-quoted-printable-string "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l")) + "Français, Español, böse, skøl") + +(deftest quoted-printable.4 + (map 'string #'code-char + (decode-quoted-printable-string "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l" + :start 12 :end 21)) + "Español") + +(deftest quoted-printable.5 + (map 'string #'code-char + (decode-quoted-printable-string "this = wrong")) + "this = wrong") + +(deftest quoted-printable.6 + (map 'string #'code-char + (decode-quoted-printable-string "this is wrong=")) + "this is wrong=") + +(deftest quoted-printable.7 + (map 'string #'code-char + (decode-quoted-printable-string "this is wrong=1")) + "this is wrong=1") + +(deftest quoted-printable.8 + (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code + "x = x + 1")) + "x =3D x + 1") + +(deftest quoted-printable.9 + (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code + "x = x + 1 ")) + "x =3D x + 1 =20") + +(deftest quoted-printable.10 + (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code + "this string is very very very very very very very very very very very very very very very very very very very very long")) + "this string is very very very very very very very very very very very ve= +ry very very very very very very very very long") + +(deftest quoted-printable.11 + (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code + "this string is very very very very long")) + "this string is very very = + very very long") + +(deftest quoted-printable.12 + (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code + "please read the next +line")) + "please read the next =20 +line") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest base64.1 + (let ((*base64-line-length* nil)) + (encode-base64-sequence (map '(vector (unsigned-byte 8)) #'char-code + "Some random string."))) + "U29tZSByYW5kb20gc3RyaW5nLg==") + +(deftest base64.2 + (let ((*base64-line-length* nil)) + (encode-base64-sequence (map '(vector (unsigned-byte 8)) #'char-code + "Some random string.") :start 5 :end 11)) + "cmFuZG9t") + +(deftest base64.3 + (map 'string #'code-char + (qbase64:decode-string "U29tZSByYW5kb20gc3RyaW5nLg==")) + "Some random string.") + +(deftest base64.4 + (map 'string #'code-char + (qbase64:decode-string "U29tZSByYW5kb20gc3RyaW5nLg==")) + "Some random string.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest RFC2047.1 + (parse-RFC2047-text "foo bar") + ("foo bar")) + +;; from RFC2047 section 8 +(deftest RFC2047.2 + (decode-RFC2047 "=?US-ASCII?Q?Keith_Moore?= <moore@cs.utk.edu>") + "Keith Moore <moore@cs.utk.edu>") + +;; from RFC2047 section 8 +(deftest RFC2047.3 + (decode-RFC2047 "=?ISO-8859-1?Q?Olle_J=E4rnefors?=") + "Olle Järnefors") + +;; from RFC2047 section 8 +(deftest RFC2047.4 + (decode-RFC2047 "Nathaniel Borenstein <nsb@thumper.bellcore.com> (=?iso-8859-8?b?7eXs+SDv4SDp7Oj08A==?=)") + "Nathaniel Borenstein <nsb@thumper.bellcore.com> (םולש ןב ילטפנ)") + +;; from RFC2047 section 8 +(deftest RFC2047.5 + (decode-RFC2047 "=?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld@dkuug.dk>") + "Keld Jørn Simonsen <keld@dkuug.dk>") + +(defun perftest-encoder (encoder-class &optional (megs 100)) + (declare (optimize (speed 3) (debug 0) (safety 0)) + (type fixnum megs)) + (with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8)) + (let* ((meg (* 1024 1024)) + (buffer (make-sequence '(vector (unsigned-byte 8)) meg)) + (encoder (make-instance encoder-class + :output-function #'(lambda (c) (declare (ignore c)))))) + (declare (type fixnum meg)) + (time + (progn + (dotimes (x megs) + (read-sequence buffer in) + (dotimes (i meg) + (mime4cl:encoder-write-byte encoder (aref buffer i)))) + (mime4cl:encoder-finish-output encoder)))))) + +(defun perftest-decoder (decoder-class &optional (megs 100)) + (declare (optimize (speed 3) (debug 0) (safety 0)) + (type fixnum megs)) + (with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8)) + (let ((*tmp-file-defaults* (make-pathname :defaults #.(or *load-pathname* *compile-file-pathname*) + :type "encoded-data"))) + (with-temp-file (tmp nil :direction :io) + (let* ((meg (* 1024 1024)) + (buffer (make-sequence '(vector (unsigned-byte 8)) meg)) + (encoder-class (ecase decoder-class + (mime4cl:quoted-printable-decoder 'mime4cl:quoted-printable-encoder))) + (encoder (make-instance encoder-class + :output-function #'(lambda (c) + (write-char c tmp)))) + (decoder (make-instance decoder-class + :input-function #'(lambda () + (read-char tmp nil))))) + (declare (type fixnum meg)) + (dotimes (x megs) + (read-sequence buffer in) + (dotimes (i meg) + (mime4cl:encoder-write-byte encoder (aref buffer i)))) + (mime4cl:encoder-finish-output encoder) + (file-position tmp 0) + (time + (loop + for b = (mime4cl:decoder-read-byte decoder) + while b))))))) diff --git a/third_party/lisp/mime4cl/test/mime.lisp b/third_party/lisp/mime4cl/test/mime.lisp new file mode 100644 index 0000000000..dbd1dd996d --- /dev/null +++ b/third_party/lisp/mime4cl/test/mime.lisp @@ -0,0 +1,41 @@ +;;; mime.lisp --- MIME regression tests + +;;; Copyright (C) 2012 by Walter C. Pelissero +;;; Copyright (C) 2021-2023 by the TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :mime4cl-tests) + +(defvar *samples-directory* + (merge-pathnames (make-pathname :directory '(:relative "samples")) + #.(or *compile-file-pathname* + *load-pathname* + #P""))) + +(loop + for f in (directory (make-pathname :defaults *samples-directory* + :name :wild + :type "msg")) + for i from 1 + do + (add-test (intern (format nil "MIME.~A" i)) + `(let* ((orig (mime-message ,f)) + (dup (mime-message + (with-output-to-string (out) (encode-mime-part orig out))))) + (mime= orig dup)) + t)) diff --git a/third_party/lisp/mime4cl/test/package.lisp b/third_party/lisp/mime4cl/test/package.lisp new file mode 100644 index 0000000000..965680448f --- /dev/null +++ b/third_party/lisp/mime4cl/test/package.lisp @@ -0,0 +1,27 @@ +;;; package.lisp --- package description for the regression tests + +;;; Copyright (C) 2006, 2009 by Walter C. Pelissero +;;; Copyright (C) 2022 by The TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(cl:in-package :common-lisp) + +(defpackage :mime4cl-tests + (:use :common-lisp + :rtest :mime4cl :mime4cl-ex-sclf) + (:export)) diff --git a/third_party/lisp/mime4cl/test/rt.lisp b/third_party/lisp/mime4cl/test/rt.lisp new file mode 100644 index 0000000000..3f3aa5c56c --- /dev/null +++ b/third_party/lisp/mime4cl/test/rt.lisp @@ -0,0 +1,258 @@ +#|----------------------------------------------------------------------------| + | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | + | Copyright 2023 by the TVL Authors | + | | + | Permission to use, copy, modify, and distribute this software and its | + | documentation for any purpose and without fee is hereby granted, provided | + | that this copyright and permission notice appear in all copies and | + | supporting documentation, and that the name of M.I.T. not be used in | + | advertising or publicity pertaining to distribution of the software | + | without specific, written prior permission. M.I.T. makes no | + | representations about the suitability of this software for any purpose. | + | It is provided "as is" without express or implied warranty. | + | | + | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | + | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | + | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | + | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | + | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | + | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | + | SOFTWARE. | + |----------------------------------------------------------------------------|# + +(defpackage #:regression-test + (:nicknames #:rtest #-lispworks #:rt) + (:use #:cl) + (:export #:*do-tests-when-defined* #:*test* #:continue-testing + #:deftest #:add-test #:do-test #:do-tests #:get-test #:pending-tests + #:rem-all-tests #:rem-test) + (:documentation "The MIT regression tester with pfdietz's modifications")) + +(in-package :regression-test) + +(defvar *test* nil "Current test name") +(defvar *do-tests-when-defined* nil) +(defvar *entries* '(nil) "Test database") +(defvar *in-test* nil "Used by TEST") +(defvar *debug* nil "For debugging") +(defvar *catch-errors* t + "When true, causes errors in a test to be caught.") +(defvar *print-circle-on-failure* nil + "Failure reports are printed with *PRINT-CIRCLE* bound to this value.") +(defvar *compile-tests* nil + "When true, compile the tests before running them.") +(defvar *optimization-settings* '((safety 3))) +(defvar *expected-failures* nil + "A list of test names that are expected to fail.") + +(defstruct (entry (:conc-name nil) + (:type list)) + pend name form) + +(defmacro vals (entry) `(cdddr ,entry)) + +(defmacro defn (entry) `(cdr ,entry)) + +(defun pending-tests () + (do ((l (cdr *entries*) (cdr l)) + (r nil)) + ((null l) (nreverse r)) + (when (pend (car l)) + (push (name (car l)) r)))) + +(defun rem-all-tests () + (setq *entries* (list nil)) + nil) + +(defun rem-test (&optional (name *test*)) + (do ((l *entries* (cdr l))) + ((null (cdr l)) nil) + (when (equal (name (cadr l)) name) + (setf (cdr l) (cddr l)) + (return name)))) + +(defun get-test (&optional (name *test*)) + (defn (get-entry name))) + +(defun get-entry (name) + (let ((entry (find name (cdr *entries*) + :key #'name + :test #'equal))) + (when (null entry) + (report-error t + "~%No test with name ~:@(~S~)." + name)) + entry)) + +(defmacro deftest (name form &rest values) + `(add-entry '(t ,name ,form .,values))) + +(defun add-test (name form &rest values) + (funcall #'add-entry (append (list 't name form) values))) + +(defun add-entry (entry) + (setq entry (copy-list entry)) + (do ((l *entries* (cdr l))) (nil) + (when (null (cdr l)) + (setf (cdr l) (list entry)) + (return nil)) + (when (equal (name (cadr l)) + (name entry)) + (setf (cadr l) entry) + (report-error nil + "Redefining test ~:@(~S~)" + (name entry)) + (return nil))) + (when *do-tests-when-defined* + (do-entry entry)) + (setq *test* (name entry))) + +(defun report-error (error? &rest args) + (cond (*debug* + (apply #'format t args) + (if error? (throw '*debug* nil))) + (error? (apply #'error args)) + (t (apply #'warn args)))) + +(defun do-test (&optional (name *test*)) + (do-entry (get-entry name))) + +(defun equalp-with-case (x y) + "Like EQUALP, but doesn't do case conversion of characters." + (cond + ((eq x y) t) + ((consp x) + (and (consp y) + (equalp-with-case (car x) (car y)) + (equalp-with-case (cdr x) (cdr y)))) + ((and (typep x 'array) + (= (array-rank x) 0)) + (equalp-with-case (aref x) (aref y))) + ((typep x 'vector) + (and (typep y 'vector) + (let ((x-len (length x)) + (y-len (length y))) + (and (eql x-len y-len) + (loop + for e1 across x + for e2 across y + always (equalp-with-case e1 e2)))))) + ((and (typep x 'array) + (typep y 'array) + (not (equal (array-dimensions x) + (array-dimensions y)))) + nil) + ((typep x 'array) + (and (typep y 'array) + (let ((size (array-total-size x))) + (loop for i from 0 below size + always (equalp-with-case (row-major-aref x i) + (row-major-aref y i)))))) + (t (eql x y)))) + +(defun do-entry (entry &optional + (s *standard-output*)) + (catch '*in-test* + (setq *test* (name entry)) + (setf (pend entry) t) + (let* ((*in-test* t) + ;; (*break-on-warnings* t) + (aborted nil) + r) + ;; (declare (special *break-on-warnings*)) + + (block aborted + (setf r + (flet ((%do + () + (if *compile-tests* + (multiple-value-list + (funcall (compile + nil + `(lambda () + (declare + (optimize ,@*optimization-settings*)) + ,(form entry))))) + (multiple-value-list + (eval (form entry)))))) + (if *catch-errors* + (handler-bind + ((style-warning #'muffle-warning) + (error #'(lambda (c) + (setf aborted t) + (setf r (list c)) + (return-from aborted nil)))) + (%do)) + (%do))))) + + (setf (pend entry) + (or aborted + (not (equalp-with-case r (vals entry))))) + + (when (pend entry) + (let ((*print-circle* *print-circle-on-failure*)) + (format s "~&Test ~:@(~S~) failed~ + ~%Form: ~S~ + ~%Expected value~P: ~ + ~{~S~^~%~17t~}~%" + *test* (form entry) + (length (vals entry)) + (vals entry)) + (format s "Actual value~P: ~ + ~{~S~^~%~15t~}.~%" + (length r) r))))) + (when (not (pend entry)) *test*)) + +(defun continue-testing () + (if *in-test* + (throw '*in-test* nil) + (do-entries *standard-output*))) + +(defun do-tests (&optional + (out *standard-output*)) + (dolist (entry (cdr *entries*)) + (setf (pend entry) t)) + (if (streamp out) + (do-entries out) + (with-open-file + (stream out :direction :output) + (do-entries stream)))) + +(defun do-entries (s) + (format s "~&Doing ~A pending test~:P ~ + of ~A tests total.~%" + (count t (cdr *entries*) + :key #'pend) + (length (cdr *entries*))) + (dolist (entry (cdr *entries*)) + (when (pend entry) + (format s "~@[~<~%~:; ~:@(~S~)~>~]" + (do-entry entry s)))) + (let ((pending (pending-tests)) + (expected-table (make-hash-table :test #'equal))) + (dolist (ex *expected-failures*) + (setf (gethash ex expected-table) t)) + (let ((new-failures + (loop for pend in pending + unless (gethash pend expected-table) + collect pend))) + (if (null pending) + (format s "~&No tests failed.") + (progn + (format s "~&~A out of ~A ~ + total tests failed: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length pending) + (length (cdr *entries*)) + pending) + (if (null new-failures) + (format s "~&No unexpected failures.") + (when *expected-failures* + (format s "~&~A unexpected failures: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length new-failures) + new-failures))) + )) + (null pending)))) diff --git a/third_party/lisp/mime4cl/test/samples/sample1.msg b/third_party/lisp/mime4cl/test/samples/sample1.msg new file mode 100644 index 0000000000..662a9fab34 --- /dev/null +++ b/third_party/lisp/mime4cl/test/samples/sample1.msg @@ -0,0 +1,86 @@ +From wcp@scylla.home.lan Fri Feb 17 11:02:28 2012 +Status: RO +X-VM-v5-Data: ([nil nil nil nil nil nil nil nil nil] + ["1133" "Friday" "17" "February" "2012" "11:02:27" "+0100" "Walter C. Pelissero" "walter@pelissero.de" nil "56" "test" "^From:" nil nil "2" nil nil nil nil nil nil nil nil nil nil] + nil) +X-Clpmr-Processed: 2012-02-17T11:02:31 +X-Clpmr-Version: 2011-10-23T12:55:20, SBCL 1.0.49 +Received: from scylla.home.lan (localhost [127.0.0.1]) + by scylla.home.lan (8.14.5/8.14.5) with ESMTP id q1HA2Sik004513 + for <wcp@scylla.home.lan>; Fri, 17 Feb 2012 11:02:28 +0100 (CET) + (envelope-from wcp@scylla.home.lan) +Received: (from wcp@localhost) + by scylla.home.lan (8.14.5/8.14.5/Submit) id q1HA2SqU004512; + Fri, 17 Feb 2012 11:02:28 +0100 (CET) + (envelope-from wcp) +Message-ID: <20286.9651.890757.323027@scylla.home.lan> +X-Mailer: VM 8.1.1 under 23.3.1 (amd64-portbld-freebsd8.2) +Reply-To: walter@pelissero.de +X-Attribution: WP +X-For-Spammers: blacklistme@pelissero.de +X-MArch-Processing-Time: 0.552s +MIME-Version: 1.0 +Content-Type: multipart/mixed; boundary="615CiWUaGO" +Content-Transfer-Encoding: 7BIT +From: walter@pelissero.de (Walter C. Pelissero) +To: wcp@scylla.home.lan +Subject: test +Date: Fri, 17 Feb 2012 11:02:27 +0100 + + +--615CiWUaGO +Content-Type: text/plain; charset="us-ascii" +Content-Transfer-Encoding: 7BIT +Content-Description: message body text + +Hereafter three attachments. + +The first: + +--615CiWUaGO +Content-Type: application/octet-stream; name="attach1" +Content-Transfer-Encoding: BASE64 +Content-Disposition: attachment; filename="attach1" + +YXR0YWNoMQo= + +--615CiWUaGO +Content-Type: text/plain; charset="us-ascii" +Content-Transfer-Encoding: 7BIT +Content-Description: message body text + + +The second: + +--615CiWUaGO +Content-Type: application/octet-stream; name="attach2" +Content-Transfer-Encoding: BASE64 +Content-Disposition: attachment; filename="attach2" + +YXR0YWNoMgo= + +--615CiWUaGO +Content-Type: text/plain; charset="us-ascii" +Content-Transfer-Encoding: 7BIT +Content-Description: message body text + + +The third: + +--615CiWUaGO +Content-Type: application/octet-stream; name="attach3" +Content-Transfer-Encoding: BASE64 +Content-Disposition: attachment; filename="attach3" + +YXR0YWNoMwo= + +--615CiWUaGO +Content-Type: text/plain; charset="us-ascii" +Content-Transfer-Encoding: 7BIT +Content-Description: .signature + + +-- +http://pelissero.de +--615CiWUaGO-- + diff --git a/third_party/lisp/mime4cl/test/temp-file.lisp b/third_party/lisp/mime4cl/test/temp-file.lisp new file mode 100644 index 0000000000..554f35844b --- /dev/null +++ b/third_party/lisp/mime4cl/test/temp-file.lisp @@ -0,0 +1,72 @@ +;;; temp-file.lisp --- temporary file creation + +;;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero +;;; Copyright (C) 2022 The TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl +;;; +;;; Code taken from SCLF + +#+cmu (ext:file-comment "$Module: temp-file.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :mime4cl-tests) + +(defvar *tmp-file-defaults* #P"/tmp/") + +(defun temp-file-name (&optional (default *tmp-file-defaults*)) + "Create a random pathname based on DEFAULT. No effort is made +to make sure that the returned pathname doesn't identify an +already existing file. If missing DEFAULT defaults to +*TMP-FILE-DEFAULTS*." + (make-pathname :defaults default + :name (format nil "~36R" (random #.(expt 36 10))))) + +(defun open-temp-file (&optional default-pathname &rest open-args) + "Open a new temporary file and return a stream to it. This function +makes sure the pathname of the temporary file is unique. OPEN-ARGS +are arguments passed verbatim to OPEN. If OPEN-ARGS specify +the :DIRECTION it should be either :OUTPUT (default) or :IO; +any other value causes an error. If DEFAULT-PATHNAME is specified and +not NIL it's used as defaults to produce the pathname of the temporary +file, otherwise *TMP-FILE-DEFAULTS* is used." + (unless default-pathname + (setf default-pathname *tmp-file-defaults*)) + ;; if :DIRECTION is specified check that it's compatible with the + ;; purpose of this function, otherwise make it default to :OUTPUT + (aif (getf open-args :direction) + (unless (member it '(:output :io)) + (error "Can't create temporary file with open direction ~A." it)) + (setf open-args (append '(:direction :output) + open-args))) + (do* ((name #1=(temp-file-name default-pathname) #1#) + (stream #2=(apply #'open name + :if-exists nil + :if-does-not-exist :create + open-args) #2#)) + (stream stream))) + +(defmacro with-temp-file ((stream &rest open-temp-args) &body body) + "Execute BODY within a dynamic extent where STREAM is bound to +a STREAM open on a unique temporary file name. OPEN-TEMP-ARGS are +passed verbatim to OPEN-TEMP-FILE." + `(let ((,stream (open-temp-file ,@open-temp-args))) + (unwind-protect + (progn ,@body) + (close ,stream) + ;; body may decide to rename the file so we must ignore the errors + (ignore-errors + (delete-file (pathname ,stream)))))) diff --git a/third_party/lisp/moptilities.nix b/third_party/lisp/moptilities.nix new file mode 100644 index 0000000000..d38fbcb946 --- /dev/null +++ b/third_party/lisp/moptilities.nix @@ -0,0 +1,13 @@ +# Compatibility layer for minor MOP implementation differences +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.moptilities; +in depot.nix.buildLisp.library { + name = "moptilities"; + deps = [ depot.third_party.lisp.closer-mop ]; + srcs = [ "${src}/dev/moptilities.lisp" ]; + + brokenOn = [ + "ecl" # TODO(sterni): https://gitlab.com/embeddable-common-lisp/ecl/-/issues/651 + ]; +} diff --git a/third_party/lisp/nibbles.nix b/third_party/lisp/nibbles.nix new file mode 100644 index 0000000000..b71f439c93 --- /dev/null +++ b/third_party/lisp/nibbles.nix @@ -0,0 +1,26 @@ +{ depot, pkgs, ... }: + +let + inherit (depot.nix.buildLisp) bundled; + src = with pkgs; srcOnly lispPackages.nibbles; +in +depot.nix.buildLisp.library { + name = "nibbles"; + + deps = with depot.third_party.lisp; [ + (bundled "asdf") + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "types.lisp" + "macro-utils.lisp" + "vectors.lisp" + "streams.lisp" + ] ++ [ + { sbcl = "${src}/sbcl-opt/fndb.lisp"; } + { sbcl = "${src}/sbcl-opt/nib-tran.lisp"; } + { sbcl = "${src}/sbcl-opt/x86-vm.lisp"; } + { sbcl = "${src}/sbcl-opt/x86-64-vm.lisp"; } + ]; +} diff --git a/third_party/lisp/npg/.project b/third_party/lisp/npg/.project new file mode 100644 index 0000000000..82a8fe48bb --- /dev/null +++ b/third_party/lisp/npg/.project @@ -0,0 +1 @@ +NPG a Naive Parser Generator diff --git a/third_party/lisp/npg/.skip-subtree b/third_party/lisp/npg/.skip-subtree new file mode 100644 index 0000000000..5051f60d6b --- /dev/null +++ b/third_party/lisp/npg/.skip-subtree @@ -0,0 +1 @@ +prevent readTree from creating entries for subdirs that don't contain an .nix files diff --git a/third_party/lisp/npg/COPYING b/third_party/lisp/npg/COPYING new file mode 100644 index 0000000000..223ede7de3 --- /dev/null +++ b/third_party/lisp/npg/COPYING @@ -0,0 +1,504 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + <one line to give the library's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + <signature of Ty Coon>, 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + + diff --git a/third_party/lisp/npg/OWNERS b/third_party/lisp/npg/OWNERS new file mode 100644 index 0000000000..2e95807063 --- /dev/null +++ b/third_party/lisp/npg/OWNERS @@ -0,0 +1 @@ +sterni diff --git a/third_party/lisp/npg/README b/third_party/lisp/npg/README new file mode 100644 index 0000000000..a1661e744a --- /dev/null +++ b/third_party/lisp/npg/README @@ -0,0 +1,48 @@ + + NPG a Naive Parser Generator + for Common Lisp + + Copyright (C) 2003-2006, 2010 by Walter C. Pelissero + Copyright (C) 2021 by the TVL Authors + +Vendored into depot as it is a dependency of mime4cl and upstream has +become inactive. Upstream and depot version may diverge. + +Upstream Website: http://wcp.sdf-eu.org/software/#npg +Vendored Tarball: http://wcp.sdf-eu.org/software/npg-20150517T144652.tbz + +This library is free software; you can redistribute it and/or modify +it under the terms of the GNU Lesser General Public License as +published by the Free Software Foundation; either version 2.1 of the +License, or (at your option) any later version. This library is +distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public +License for more details. You should have received a copy of the GNU +Lesser General Public License along with this library; if not, write +to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +Boston, MA 02111-1307 USA + + +This library generates on the fly (no external representation of the +parser is produced) a recursive descent parser based on the grammar +rules you have fed it with. The parser object can then be used to +scan tokenised input. Although a facility to produce a lexical +analiser is not provided, to write such a library is fairly easy for +most languages. NPG parsers require your lexer to adhere to a certain +protocol to be able to communicate with them. Examples are provided +that explain these requirements. + +While quite possibly not producing the fastest parsers in town, it's +fairly simple and hopefully easy to debug. It accepts a lispy EBNF +grammar description of arbitrary complexity with the exception of +mutually left recursive rules (watch out, they produce undetected +infinite recursion) and produces a backtracking recursive descent +parser. Immediate left recursive rules are properly simplified, +though. + +Multiple concurrent parsers are supported. + +To compile, an ASDF and nix file are provided. + +See the examples directory for clues on how to use it. diff --git a/third_party/lisp/npg/default.nix b/third_party/lisp/npg/default.nix new file mode 100644 index 0000000000..af7ec53eaf --- /dev/null +++ b/third_party/lisp/npg/default.nix @@ -0,0 +1,14 @@ +# Copyright (C) 2021 by the TVL Authors +# SPDX-License-Identifier: LGPL-2.1-or-later +{ depot, pkgs, ... }: + +depot.nix.buildLisp.library { + name = "npg"; + + srcs = [ + ./src/package.lisp + ./src/common.lisp + ./src/define.lisp + ./src/parser.lisp + ]; +} diff --git a/third_party/lisp/npg/examples/python.lisp b/third_party/lisp/npg/examples/python.lisp new file mode 100644 index 0000000000..a45ac614f7 --- /dev/null +++ b/third_party/lisp/npg/examples/python.lisp @@ -0,0 +1,336 @@ +;;; python.lisp --- sample grammar definition for the Python language + +;;; Copyright (C) 2003 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator +;;; $Id: F-C1A8CD5961889C584B22F05E8B956006.lisp,v 1.3 2004/03/09 10:33:06 wcp Exp $ + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;; Commentary: +;;; +;;; This is far from being a complete Python grammar. Actually I +;;; haven't even read a Python book before starting to write this +;;; stuff, so the code below comes mostly from wild guessing while +;;; reading a Python source file. +;;; +;;; It's a design decision to avoid writing any transformation in this +;;; module; only tagging is done at this level. This improves the +;;; separation between parsing and transformation, making the grammar +;;; reusable for other purposes. + + +#+cmu (ext:file-comment "$Id: F-C1A8CD5961889C584B22F05E8B956006.lisp,v 1.3 2004/03/09 10:33:06 wcp Exp $") + +(in-package :grammar) + +(deflazy define-grammar + (let ((*package* #.*package*) + (*compile-print* (and parser::*debug* t))) + (reset-grammar) + (format t "~&creating Python grammar...~%") + (populate-grammar) + (let ((grammar (parser:generate-grammar))) + (reset-grammar) + (parser:print-grammar-figures grammar) + grammar))) + +(defun populate-grammar () + +(defrule program + := comment-string? statement+) + +(defrule comment-string + := string eol + :reduce string) + +;;; BOB = Beginning Of Block, EOB = End Of Block. It's lexical +;;; analyzer's task to find out where a statement or block starts/ends. + +(defrule suite + := statement-list eol + :reduce statement-list + := statement-block) + +(defrule commentable-suite + := statement-list eol + :reduce statement-list + := commented-statement-block) + +(defrule statement-block + := bob statement+ eob + :reduce $2) + +(defrule commented-statement-block + := bob comment-string? statement* eob + :reduce (cons comment-string statement)) + +(defrule statement-list + := (+ simple-statement ";") + :reduce (if (cdr $1) + (cons :statement-list $1) + (car $1))) + +(defrule statement + := statement-list eol + :reduce statement-list + := compound-statement) + +(defrule simple-statement + := import-statement + := raise-statement + := assignment + := function-call + := return-statement + := assert-statement + := pass-statement + := break-statement + := continue-statement) + +(defrule compound-statement + := class-definition + := method-definition + := try-statement + := if-statement + := while-statement + := for-statement) + +(defrule import-statement + := "import" (+ package-name ",") + :tag :import + := "from" package-name "import" (+ symbol-name ",") + :tag :import-from) + +(defrule package-name := identifier) + +(defrule symbol-name + := identifier + := "*") + +(defrule try-statement + := "try" ":" suite try-except-part* try-finally-part? + :tag :try) + +(defrule try-except-part + := "except" exception-subject? ":" suite) + +(defrule try-finally-part + := "finally" ":" suite) + +(defrule exception-subject + := exception-name exception-variable?) + +(defrule exception-variable + := "," identifier) + +(defrule exception-name := class-name) + +(defrule class-name := identifier) + +(defrule raise-statement + := "raise" + :tag :raise-same + := "raise" exception-name + :tag :raise + := "raise" exception-name "," expression + :tag :raise + := "raise" exception-name "(" expression ")" + :tag :raise) + +(defrule assignment + := (+ variable-with-optional-subscript ",") "=" more-assignment + :tag :set) + +(defrule more-assignment + := expression + := assignment) + +(defrule variable-with-optional-subscript + := variable-name subscript + :tag :subscript + := variable-name) + +(defrule variable-name + := (+ identifier ".") + :tag :varef) + +(defrule expression + := expression "or" expression1 + :tag :or + := expression1) + +(defrule expression1 + := expression1 "and" expression2 + :tag :and + := expression2) + +(defrule expression2 + := expression2 "==" expression3 + :tag :equal + := expression2 ">=" expression3 + :tag :more-equal + := expression2 "<=" expression3 + :tag :less-equal + := expression2 "!=" expression3 + :tag :not-equal + := expression2 ">" expression3 + :tag :more + := expression2 "<" expression3 + :tag :less + := expression2 "is" expression3 + :tag :equal + := expression2 "is" "not" expression3 + :tag :not-equal + := expression3) + +(defrule expression3 + := expression3 "+" expression4 + :tag :plus + := expression3 "-" expression4 + :tag :minus + := expression3 "|" expression4 + :tag :bit-or + := expression4) + +;; high priority expression +(defrule expression4 + := expression4 "*" expression5 + :tag :mult + := expression4 "/" expression5 + :tag :div + := expression4 "%" expression5 + :tag :modulo + := expression4 "&" expression5 + :tag :bit-and + := expression4 "in" expression5 + :tag :in + := expression5) + +(defrule expression5 + := "~" expression5 + :tag :bit-not + := "not" expression5 + :tag :not + := "(" expression ")" + := expression6) + +(defrule expression6 + := simple-expression subscript + :tag :subscript + := simple-expression) + +(defrule simple-expression + := function-call + := variable-name + := constant + := string-conversion + := list-constructor) + +(defrule subscript + := "[" expression "]" + := "[" expression ":" expression "]" + := "[" expression ":" "]" + :reduce (list expression nil) + := "[" ":" expression "]" + :reduce (list nil expression)) + +(defrule string-conversion + := "`" expression "`" + :tag :to-string) + +(defrule constant + := number + := string + := lambda-expression) + +(defrule number + := float + := integer) + +(defrule list-constructor + := "[" (* expression ",") "]" + :tag :make-list) + +(defrule class-definition + := "class" class-name superclasses? ":" commentable-suite + :tag :defclass) + +(defrule superclasses + := "(" class-name+ ")") + +(defrule method-definition + := "def" method-name "(" method-arguments ")" ":" commentable-suite + :tag :defmethod) + +(defrule method-arguments + := (* method-argument ",")) + +(defrule method-argument + := identifier argument-default?) + +(defrule argument-default + := "=" expression) + +(defrule method-name := identifier) + +(defrule if-statement + := "if" expression ":" suite elif-part* else-part? + :tag :if) + +(defrule else-part + := "else" ":" suite) + +(defrule elif-part + := "elif" expression ":" suite) + +(defrule lambda-expression + := "lambda" method-arguments ":" expression + :tag :lambda) + +(defrule function-call + := (+ identifier ".") "(" (* expression ",") ")" + :tag :funcall) + +(defrule for-statement + := "for" identifier "in" expression ":" suite + :tag :do-list + := "for" identifier "in" "range" "(" expression "," expression ")" ":" suite + :tag :do-range) + +(defrule while-statement + := "while" expression ":" suite + :tag :while) + +(defrule return-statement + := "return" expression? + :tag :return) + +(defrule assert-statement + := "assert" expression "," string + :tag :assert) + +(defrule pass-statement + := "pass" + :tag :pass) + +(defrule break-statement + := "break" + :tag :break) + +(defrule continue-statement + := "continue" + :tag :continue) + +) ; end of POPULATE-GRAMMAR diff --git a/third_party/lisp/npg/examples/vs-cobol-ii.lisp b/third_party/lisp/npg/examples/vs-cobol-ii.lisp new file mode 100644 index 0000000000..9ebd45a169 --- /dev/null +++ b/third_party/lisp/npg/examples/vs-cobol-ii.lisp @@ -0,0 +1,1901 @@ +;;; vs-cobol-ii.lisp --- sample grammar for VS-Cobol II + +;;; Copyright (C) 2003 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator +;;; $Id: F-1D03709AEB30BA7644C1CFA2DF60FE8C.lisp,v 1.2 2004/03/09 10:33:07 wcp Exp $ + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;; Commentary: +;;; +;;; A fairly incomplete VS-Cobol II grammar fro NPG. It's probably +;;; not very accurate either. + +#+cmu (ext:file-comment "$Id: F-1D03709AEB30BA7644C1CFA2DF60FE8C.lisp,v 1.2 2004/03/09 10:33:07 wcp Exp $") + +(in-package :grammar) + +(defun make-keyword (string) + "Create a keyword from STRING." + (intern (string-upcase string) :keyword)) + +(defun flatten-list (list) + "Remove one depth level in LIST." + (mapcan #'identity list)) + +(deflazy define-grammar + (let ((*package* #.*package*) + (*compile-print* (and parser::*debug* t))) + (reset-grammar) + (format t "creating Cobol grammar...~%") + (populate-grammar) + (let ((grammar (parser:generate-grammar))) + (reset-grammar) + (parser:print-grammar-figures grammar) + grammar))) + +(defun populate-grammar () +;;; +;;; Hereafter PP means Partial Program +;;; + +#+nil +(defrule pp--declarations + := identification-division environment-division? data-division? "PROCEDURE" "DIVISION" using-phrase? "." :rest) + +;;; We need to split the parsing of the declarations from the rest +;;; because the declarations may change the lexical rules (ie decimal +;;; point) + +(defrule pp--declarations + := identification-division environment-division? data-division-head-or-procedure-division-head :rest) + +(defrule data-division-head-or-procedure-division-head + := data-division-head + :reduce :data-division + := procedure-division-head + :reduce (list :procedure-division $1)) + +(defrule pp--data-division + := data-division-content procedure-division-head :rest) + +(defrule pp--sentence + := sentence :rest + := :eof) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The real grammar +;;; + +(defrule cobol-source-program + := identification-division environment-division? data-division procedure-division end-program?) + +(defrule identification-division + := identification "DIVISION" "." program-id-cobol-source-program identification-division-content + :reduce program-id-cobol-source-program) + +(defrule priority-number + := integer) + +(defrule level-number + := integer) + +(defrule to-id-or-lit + := "TO" id-or-lit) + +(defrule inspect-by-argument + := variable-identifier + := string + := figurative-constant-simple) + +(defrule figurative-constant-simple + := "ZERO" + :reduce :zero + := "ZEROS" + :reduce :zero + := "ZEROES" + :reduce :zero + := "SPACE" + :reduce :space + := "SPACES" + :reduce :space + := "HIGH-VALUE" + :reduce :high + := "HIGH-VALUES" + :reduce :high + := "LOW-VALUE" + :reduce :low + := "LOW-VALUES" + :reduce :low + := "QUOTE" + :reduce :quote + := "QUOTES" + :reduce :quote + := "NULL" + :reduce :null + := "NULLS" + :reduce :null) + +(defrule write-exceptions + := at-end-of-page-statement-list? not-at-end-of-page-statement-list? invalid-key-statement-list? not-invalid-key-statement-list?) + +(defrule set-statement-phrase + := variable-identifier+ set-oper set-src) + +(defrule set-src + := variable-identifier + := literal + := "TRUE" + := "ON" + := "OFF") + +(defrule set-oper + := "TO" + :reduce :to + := "UP" "BY" + :reduce :up + := "DOWN" "BY" + :reduce :down) + +(defrule fce-phrase + := reserve-clause + := fce-organization + := fce-access-mode + := record-key-clause + := password-clause + := alternate-record-key-clause + := file-status-clause + := padding-character-clause + := record-delimiter-clause) + +(defrule fce-organization + := organization-is? alt-indexed-relative-sequential + :reduce (list :organization (make-keyword alt-indexed-relative-sequential))) + +(defrule fce-access-mode + := "ACCESS" "MODE"? "IS"? alt-sequential-random-dynamic relative-key-clause? + :reduce (list :access-mode (make-keyword alt-sequential-random-dynamic))) + +(defrule alt-indexed-relative-sequential + := "INDEXED" + := "RELATIVE" + := "SEQUENTIAL") + +(defrule is-not + := "IS"? "NOT"?) + +(defrule all-procedures + := "ALL" "PROCEDURES") + +(defrule next-sentence + := "NEXT" "SENTENCE") + +(defrule no-rewind + := "NO" "REWIND") + +(defrule for-removal + := "FOR"? "REMOVAL") + +(defrule values + := "VALUE" + := "VALUES") + +(defrule records + := "RECORD" + := "RECORDS") + +(defrule end-program + := "END" "PROGRAM" program-name ".") + +(defrule environment-division + := "ENVIRONMENT" "DIVISION" "." environment-division-content) + +(defrule data-division-head + := "DATA" "DIVISION" ".") + +(defrule data-division + := data-division-head data-division-content + :reduce data-division-content) + +(defrule identification + := "IDENTIFICATION" + := "ID") + +(defrule identification-division-content + := identification-division-phrase*) + +(defrule author + := "AUTHOR" ".") + +(defrule installation + := "INSTALLATION" ".") + +(defrule date-written + := "DATE-WRITTEN" ".") + +(defrule date-compiled + := "DATE-COMPILED" ".") + +(defrule security + := "SECURITY" ".") + +(defrule remarks + := "REMARKS" ".") + +(defrule identification-division-phrase + := author + := installation + := date-written + := date-compiled + := security + := remarks) + +(defrule program-id-cobol-source-program + := "PROGRAM-ID" "."? program-name initial-program? "." + :reduce program-name) + +(defrule initial-program + := "IS"? "INITIAL" "PROGRAM"?) + +(defrule environment-division-content + := configuration-section? input-output-section?) + +(defrule input-output-section + := "INPUT-OUTPUT" "SECTION" "." file-control-paragraph? i-o-control-paragraph? + :reduce file-control-paragraph) + +(defrule file-control-paragraph + := "FILE-CONTROL" "." file-control-entry*) + +(defrule file-control-entry + := select-clause assign-clause fce-phrase* "." + :reduce (append select-clause + assign-clause + (flatten-list fce-phrase))) + +(defrule organization-is + := "ORGANIZATION" "IS"?) + +(defrule alt-sequential-random-dynamic + := "SEQUENTIAL" + := "RANDOM" + := "DYNAMIC") + +(defrule select-clause + := "SELECT" "OPTIONAL"? file-name + :reduce (list file-name :optional (and $2 t))) + +(defrule assign-clause + := "ASSIGN" "TO"? alt-assignment-name-literal+ + :reduce (list :assign alt-assignment-name-literal)) + +(defrule alt-assignment-name-literal + := assignment-name + := literal) + +(defrule reserve-clause + := "RESERVE" integer areas?) + +(defrule areas + := "AREA" + := "AREAS") + +(defrule padding-character-clause + := "PADDING" "CHARACTER"? "IS"? alt-qualified-data-name-literal) + +(defrule record-delimiter-clause + := "RECORD" "DELIMITER" "IS"? record-delimiter-name) + +(defrule record-delimiter-name + := "STANDARD-1" + := assignment-name) + +(defrule password-clause + := "PASSWORD" "IS"? data-name) + +(defrule file-status-clause + := "FILE"? "STATUS" "IS"? qualified-data-name qualified-data-name? + :reduce (list :file-status qualified-data-name)) + +(defrule relative-key-clause + := "RELATIVE" "KEY"? "IS"? qualified-data-name + :reduce (list :relative-key qualified-data-name)) + +(defrule record-key-clause + := "RECORD" "KEY"? "IS"? qualified-data-name + :reduce (list :key qualified-data-name)) + +(defrule alternate-record-key-clause + := "ALTERNATE" "RECORD"? "KEY"? "IS"? qualified-data-name password-clause? with-duplicates? + :reduce (list :alternate-key qualified-data-name with-duplicates)) + +(defrule with-duplicates + := "WITH"? "DUPLICATES") + +(defrule i-o-control-paragraph + := "I-O-CONTROL" "." i-o-sam? i-o-sort-merge?) + +(defrule i-o-sam + := qsam-or-sam-or-vsam-i-o-control-entries+ ".") + +(defrule i-o-sort-merge + := sort-merge-i-o-control-entries ".") + +(defrule qsam-or-sam-or-vsam-i-o-control-entries + := qsam-or-sam-or-vsam-i-o-control-entries-1 + := qsam-or-sam-or-vsam-i-o-control-entries-2 + := qsam-or-sam-or-vsam-i-o-control-entries-3 + := qsam-or-sam-or-vsam-i-o-control-entries-4) + +(defrule qsam-or-sam-or-vsam-i-o-control-entries-1 + := "RERUN" "ON" alt-assignment-name-file-name "EVERY"? every-phrase "OF"? file-name) + +(defrule every-phrase-1 + := integer "RECORDS") + +(defrule every-phrase-2 + := "END" "OF"? alt-reel-unit) + +(defrule every-phrase + := every-phrase-1 + := every-phrase-2) + +(defrule alt-assignment-name-file-name + := assignment-name + := file-name) + +(defrule qsam-or-sam-or-vsam-i-o-control-entries-2 + := "SAME" "RECORD"? "AREA"? "FOR"? file-name file-name+) + +(defrule qsam-or-sam-or-vsam-i-o-control-entries-3 + := "MULTIPLE" "FILE" "TAPE"? "CONTAINS"? file-name-position+) + +(defrule position + := "POSITION" integer) + +(defrule file-name-position + := file-name position?) + +(defrule qsam-or-sam-or-vsam-i-o-control-entries-4 + := "APPLY" "WRITE-ONLY" "ON"? file-name+) + +(defrule sort-merge-i-o-control-entries + := rerun-on? same-area+) + +(defrule rerun-on + := "RERUN" "ON" assignment-name) + +(defrule record-sort + := "RECORD" + := "SORT" + := "SORT-MERGE") + +(defrule same-area + := "SAME" record-sort "AREA"? "FOR"? file-name file-name+) + +(defrule configuration-section + := "CONFIGURATION" "SECTION" "." configuration-section-paragraph* + :reduce (flatten-list configuration-section-paragraph)) + +(defrule configuration-section-paragraph + := source-computer-paragraph + := object-computer-paragraph + := special-names-paragraph) + +(defrule source-computer-paragraph + := "SOURCE-COMPUTER" "." source-computer-name + :reduce (list :source-computer source-computer-name)) + +(defrule with-debugging-mode + := "WITH"? "DEBUGGING" "MODE") + +(defrule source-computer-name + := computer-name with-debugging-mode? "." + :reduce computer-name) + +(defrule object-computer-paragraph + := "OBJECT-COMPUTER" "." object-computer-name + :reduce (list :object-computer object-computer-name)) + +(defrule memory-size-type + := "WORDS" + := "CHARACTERS" + := "MODULES") + +(defrule memory-size + := "MEMORY" "SIZE"? integer memory-size-type) + +(defrule object-computer-name + := computer-name memory-size? object-computer-paragraph-sequence-phrase "." + :reduce computer-name) + +(defrule object-computer-paragraph-sequence-phrase + := program-collating-sequence? segment-limit?) + +(defrule program-collating-sequence + := "PROGRAM"? "COLLATING"? "SEQUENCE" "IS"? alphabet-name) + +(defrule segment-limit + := "SEGMENT-LIMIT" "IS"? priority-number) + +(defrule special-names-paragraph + := "SPECIAL-NAMES" "." special-names-paragraph-phrase* special-names-paragraph-clause* "." + :reduce (flatten-list special-names-paragraph-clause)) + +(defrule is-mnemonic-name + := "IS"? mnemonic-name special-names-paragraph-status-phrase?) + +(defrule special-names-paragraph-phrase-tail + := is-mnemonic-name + := special-names-paragraph-status-phrase) + +(defrule special-names-paragraph-phrase + := environment-name special-names-paragraph-phrase-tail) + +(defrule special-names-paragraph-status-phrase + := special-names-paragraph-status-phrase-1 + := special-names-paragraph-status-phrase-2) + +(defrule special-names-paragraph-status-phrase-1 + := "ON" "STATUS"? "IS"? condition off-status?) + +(defrule off-status + := "OFF" "STATUS"? "IS"? condition) + +(defrule special-names-paragraph-status-phrase-2 + := "OFF" "STATUS"? "IS"? condition on-status?) + +(defrule on-status + := "ON" "STATUS"? "IS"? condition) + +(defrule special-names-paragraph-clause + ;; := alphabet-clause + ;; := symbolic-characters-clause + := currency-sign-clause + := decimal-point-clause) + +(defrule alphabet-clause + := "ALPHABET" alphabet-name "IS"? alphabet-type) + +(defrule alphabet-type-also + := "ALSO" literal) + +(defrule alphabet-type-alsos + := alphabet-type-also+) + +(defrule alphabet-type-also-through + := through-literal + := alphabet-type-alsos) + +(defrule alphabet-type-other + := literal alphabet-type-also-through?) + +(defrule alphabet-type-others + := alphabet-type-other+) + +(defrule alphabet-type + := "STANDARD-1" + := "STANDARD-2" + := "NATIVE" + := "EBCDIC" + := alphabet-type-others) + +(defrule symbolic-characters-clause + := "SYMBOLIC" "CHARACTERS"? symbolic-character-mapping+ in-alphabet-name?) + +(defrule are + := "ARE" + := "IS") + +(defrule symbolic-character-mapping + := symbolic-character+ are? integer+) + +(defrule in-alphabet-name + := "IN" alphabet-name) + +(defrule currency-sign-clause + := "CURRENCY" "SIGN"? "IS"? literal + :reduce (list :currency-sign literal)) + +(defrule decimal-point-clause + := "DECIMAL-POINT" "IS"? "COMMA" + :reduce (list :decimal-point #\,)) + +(defrule data-division-content + := file-section? working-storage-section? linkage-section?) + +(defrule file-section-entry + := file-and-sort-description-entry data-description-entry+ + :reduce (cons file-and-sort-description-entry data-description-entry)) + +(defrule file-section-head + := "FILE" "SECTION" ".") + +(defrule file-section + := file-section-head file-section-entry* + :reduce $2) + +(defrule working-storage-section-head + := "WORKING-STORAGE" "SECTION" ".") + +(defrule working-storage-section + := working-storage-section-head data-description-entry* + :reduce $2) + +(defrule linkage-section-head + := "LINKAGE" "SECTION" ".") + +(defrule linkage-section + := linkage-section-head data-description-entry* + :reduce $2) + +(defrule file-and-sort-description-entry + := alt-fd-sd file-name file-and-sort-description-entry-clause* "." + :reduce (list (make-keyword alt-fd-sd) file-name file-and-sort-description-entry-clause)) + +(defrule alt-fd-sd + := "FD" + := "SD") + +(defrule file-and-sort-description-entry-clause + := external-clause + := global-clause + := block-contains-clause + := record-clause + := label-records-clause + := value-of-clause + := data-records-clause + := linage-clause + := recording-mode-clause + := code-set-clause) + +(defrule integer-to + := integer "TO") + +(defrule block-contains-clause + := "BLOCK" "CONTAINS"? integer-to? integer alt-characters-records?) + +(defrule alt-characters-records + := "CHARACTERS" + := "RECORDS" + := "RECORD") + +(defrule record-clause + := "RECORD" record-clause-tail) + +(defrule depending-on + := "DEPENDING" "ON"? data-name) + +(defrule record-clause-tail-1 + := "CONTAINS"? integer "CHARACTERS"?) + +(defrule record-clause-tail-2 + := "CONTAINS"? integer "TO" integer "CHARACTERS"?) + +(defrule record-clause-tail-3 + := record-varying-phrase depending-on?) + +(defrule record-clause-tail + := record-clause-tail-2 + := record-clause-tail-1 + := record-clause-tail-3) + +(defrule record-varying-phrase + := "IS"? "VARYING" "IN"? "SIZE"? from-integer? to-integer? "CHARACTERS"?) + +(defrule from-integer + := "FROM"? integer) + +(defrule to-integer + := "TO" integer) + +(defrule label-records-clause + := "LABEL" records-are label-records-clause-tail + :reduce (list :label-record label-records-clause-tail)) + +(defrule data-names + := data-name+) + +(defrule label-records-clause-tail + := "STANDARD" :reduce :standard + := "OMITTED" :reduce :omitted + := data-names) + +(defrule value-of-clause + := "VALUE" "OF" value-of-clause-tail+) + +(defrule alt-qualified-data-name-literal + := qualified-data-name + := literal) + +(defrule value-of-clause-tail + := variable-identifier "IS"? alt-qualified-data-name-literal) + +(defrule data-records-clause + := "DATA" records-are data-name+) + +(defrule records-are + := records are?) + +(defrule linage-clause + := "LINAGE" "IS"? alt-data-name-integer "LINES"? linage-footing-phrase) + +(defrule linage-footing-phrase + := footing? lines-top? lines-bottom?) + +(defrule alt-data-name-integer + := data-name + := integer) + +(defrule footing + := "WITH"? "FOOTING" "AT"? alt-data-name-integer) + +(defrule lines-top + := "LINES"? "AT"? "TOP" alt-data-name-integer) + +(defrule lines-bottom + := "LINES"? "AT"? "BOTTOM" alt-data-name-integer) + +(defrule recording-mode-clause + := "RECORDING" "MODE"? "IS"? variable-identifier) + +(defrule code-set-clause + := "CODE-SET" "IS"? alphabet-name) + +(defrule data-description-entry + := level-number alt-data-name-filler? data-description-entry-clause* "." + :reduce (append (list level-number alt-data-name-filler) + (flatten-list data-description-entry-clause))) + +(defrule alt-data-name-filler + := data-name + := "FILLER" + :reduce (list)) + +(defrule data-description-entry-clause + := picture-clause + := redefines-clause + := blank-when-zero-clause + := external-clause + := global-clause + := justified-clause + := occurs-clause + := sign-clause + := synchronized-clause + := usage-clause + := renames-clause + := value-clause) + +(defrule value-clause + := "VALUE" "IS"? literal + :reduce (list :value literal)) + +(defrule redefines-clause + := "REDEFINES" data-name + :reduce `(:redefines ,data-name)) + +(defrule blank-when-zero-clause + := "BLANK" "WHEN"? zeroes + :reduce '(:blank-when-zero t)) + +(defrule zeroes + := "ZERO" + := "ZEROS" + := "ZEROES") + +(defrule external-clause + := "IS"? "EXTERNAL" + :reduce '(:external t)) + +(defrule global-clause + := "IS"? "GLOBAL" + :reduce '(:global t)) + +(defrule justified-clause + := justified "RIGHT"? + :reduce `(:justified ,(if $2 :right :left))) + +(defrule justified + := "JUSTIFIED" + := "JUST") + +(defrule occurs-clause + := "OCCURS" integer "TIMES"? occurs-clause-key* indexed-by? + ;; to be completed -wcp16/7/03. + :reduce `(:times ,integer) + := "OCCURS" integer "TO" integer "TIMES"? "DEPENDING" "ON"? qualified-data-name occurs-clause-key* indexed-by? + ;; to be completed -wcp16/7/03. + :reduce `(:times (,integer ,integer2 ,qualified-data-name))) + +(defrule occurs-clause-key + := alt-ascending-descending "KEY"? "IS"? qualified-data-name+) + +(defrule indexed-by + := "INDEXED" "BY"? index-name+) + +(defrule picture-clause + := picture "IS"? picture-string + :reduce `(:picture ,picture-string)) + +(defrule picture + := "PICTURE" + := "PIC") + +(defrule sign-clause + := sign-is? alt-leading-trailing separate-character? + :reduce `(:separate-sign ,separate-character :sign-position ,alt-leading-trailing)) + +(defrule sign-is + := "SIGN" "IS"?) + +(defrule separate-character + := "SEPARATE" "CHARACTER"? + :reduce t) + +(defrule alt-leading-trailing + := "LEADING" + :reduce :leading + := "TRAILING" + :reduce :trailing) + +(defrule synchronized-clause + := synchronized alt-left-right? + :reduce `(:synchronized ,(if alt-left-right + alt-left-right + t))) + +(defrule alt-left-right + := "LEFT" + :reduce :left + := "RIGHT" + :reduce :right) + +(defrule synchronized + := "SYNCHRONIZED" + := "SYNC") + +(defrule usage-clause + := usage-is? usage + :reduce (list :encoding usage)) + +(defrule usage-is + := "USAGE" "IS"?) + +(defrule usage + := "BINARY" + :reduce :binary + := "COMP" + :reduce :comp + := "COMP-1" + :reduce :comp1 + := "COMP-2" + :reduce :comp2 + := "COMP-3" + :reduce :comp3 + := "COMP-4" + :reduce :comp4 + := "COMPUTATIONAL" + :reduce :comp + := "COMPUTATIONAL-1" + :reduce :comp1 + := "COMPUTATIONAL-2" + :reduce :comp2 + := "COMPUTATIONAL-3" + :reduce :comp3 + := "COMPUTATIONAL-4" + :reduce :comp4 + := "DISPLAY" + :reduce :display + := "DISPLAY-1" + :reduce :display1 + := "INDEX" + :reduce :index + := "PACKED-DECIMAL" + :reduce :packed-decimal + := "POINTER" + :reduce :pointer) + +(defrule renames-clause + := "RENAMES" qualified-data-name through-qualified-data-name? + :reduce `(:renames ,qualified-data-name ,through-qualified-data-name)) + +(defrule through-qualified-data-name + := through qualified-data-name + :reduce qualified-data-name) + +(defrule condition-value-clause + := values-are literal-through-literal+) + +(defrule through-literal + := through literal) + +(defrule literal-through-literal + := literal through-literal?) + +(defrule values-are + := values are?) + +(defrule procedure-division-head + := "PROCEDURE" "DIVISION" using-phrase? ".") + +(defrule procedure-division + := procedure-division-head sentence+) + +(defrule using-phrase + := "USING" data-name+) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defrule declaratives + := "DECLARATIVES" "." declaratives-content+ "END" "DECLARATIVES" ".") + +(defrule declaratives-content + := cobol-identifier "SECTION" "." use-statement "." sentence*) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defrule paragraph-header + := cobol-identifier "SECTION"? + :reduce (list (if $2 :section :label) $1)) + +(defrule sentence + := declaratives + := statement* "." + :reduce $1 + := paragraph-header "." + :reduce $1) + +(defrule statement + := move-statement + := if-statement + := perform-statement + := go-to-statement + := accept-statement + := add-statement + := alter-statement + := call-statement + := cancel-statement + := close-statement + := compute-statement + := continue-statement + := delete-statement + := display-statement + := divide-statement + := entry-statement + := evaluate-statement + := exit-program-statement + := exit-statement + := goback-statement + := initialize-statement + := inspect-statement + := merge-statement + := multiply-statement + := open-statement + := read-statement + := release-statement + := return-statement + := rewrite-statement + := search-statement + := set-statement + := sort-statement + := start-statement + := stop-statement + := string-statement + := subtract-statement + := unstring-statement + := write-statement + := paragraph-header) + +(defrule accept-statement + := "ACCEPT" variable-identifier "FROM" date + := "ACCEPT" variable-identifier "AT" screen-coordinates + :reduce (apply #'list 'accept-at variable-identifier screen-coordinates) + := "ACCEPT" variable-identifier from-environment-name?) + +(defrule from-environment-name + := "FROM" cobol-identifier) + + +(defrule date + := "DATE" + := "DAY" + := "DAY-OF-WEEK" + := "TIME") + +(defrule add-statement + := "ADD" id-or-lit+ to-id-or-lit? "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"? + := "ADD" id-or-lit+ "TO" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"? + := "ADD" corresponding variable-identifier "TO" variable-identifier "ROUNDED"? on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"?) + +(defrule statement-list + := statement+) + +(defrule alter-statement + := "ALTER" procedure-to-procedure+) + +(defrule proceed-to + := "PROCEED" "TO") + +(defrule procedure-to-procedure + := procedure-name "TO" proceed-to? procedure-name) + +(defrule call-statement + := "CALL" id-or-lit using-parameters? call-rest-phrase "END-CALL"? + :reduce (list 'call id-or-lit (cons 'list using-parameters))) + +(defrule by-reference + := "BY"? "REFERENCE") + +(defrule content-parameter-value + := cobol-identifier + := literal) + +(defrule reference-parameter + := by-reference? variable-identifier) + +(defrule content-parameter + := "BY"? "CONTENT" content-parameter-value+) + +(defrule parameter + := reference-parameter + := content-parameter + := literal) + +(defrule using-parameters + := "USING" parameter+) + +(defrule call-rest-phrase + := on-exception-statement-list? not-on-exception-statement-list? on-overflow-statement-list?) + +(defrule on-exception-statement-list + := "ON"? "EXCEPTION" statement-list) + +(defrule not-on-exception-statement-list + := "NOT" "ON"? "EXCEPTION" statement-list) + +(defrule cancel-statement + := "CANCEL" id-or-lit+) + +(defrule close-statement + := "CLOSE" close-statement-file-name+ + :reduce (list 'close close-statement-file-name)) + +(defrule alt-removal-no-rewind + := for-removal + := with-no-rewind) + +(defrule alt-reel-unit + := "REEL" + := "UNIT") + +(defrule alt-no-rewind-lock + := no-rewind + := "LOCK") + +(defrule close-statement-options-1 + := alt-reel-unit alt-removal-no-rewind?) + +(defrule close-statement-options-2 + := "WITH"? alt-no-rewind-lock) + +(defrule close-statement-options + := close-statement-options-1 + := close-statement-options-2) + +(defrule close-statement-file-name + := file-name close-statement-options?) + +(defrule compute-statement + := "COMPUTE" cobword-rounded+ equal arithmetic-expression on-size-error-statement-list? not-on-size-error-statement-list? "END-COMPUTE"? + :reduce (list 'compute cobword-rounded arithmetic-expression :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list)) + +(defrule equal + := "=" + := "EQUAL") + +(defrule continue-statement + := "CONTINUE") + +(defrule delete-statement + := "DELETE" file-name "RECORD"? invalid-key-statement-list? not-invalid-key-statement-list? "END-DELETE"? + :reduce (list 'delete file-name :invalid invalid-key-statement-list :not-invalid not-invalid-key-statement-list)) + +(defrule display-statement + := "DISPLAY" id-or-lit+ upon-environment-name? with-no-advancing? + :reduce (list 'display (cons 'list id-or-lit) :upon upon-environment-name :advance (not with-no-advancing)) + := "DISPLAY" id-or-lit "AT" screen-coordinates + :reduce (apply #'list 'display-at id-or-lit screen-coordinates)) + +(defrule screen-coordinates + := integer + :reduce (multiple-value-list (truncate integer 100))) + +(defrule upon-environment-name + := "UPON" cobol-identifier) + +(defrule with-no-advancing + := "WITH"? "NO" "ADVANCING") + +(defrule divide-statement + := "DIVIDE" id-or-lit "INTO" id-or-lit "GIVING" variable-identifier "ROUNDED"? "REMAINDER" variable-identifier on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"? + := "DIVIDE" id-or-lit "BY" id-or-lit "GIVING" variable-identifier "ROUNDED"? "REMAINDER" variable-identifier on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"? + := "DIVIDE" id-or-lit "INTO" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"? + := "DIVIDE" id-or-lit "BY" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"? + := "DIVIDE" id-or-lit "INTO" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?) + +(defrule entry-statement + := "ENTRY" literal using-phrase?) + +(defrule evaluate-statement + := "EVALUATE" evaluate-condition also-phrase* when-phrases+ when-other-phrase? "END-EVALUATE"?) + +(defrule evaluate-condition + := condition + := "TRUE" + := "FALSE") + +(defrule also-phrase + := "ALSO" evaluate-condition) + +(defrule when-phrase-also-phrase + := "ALSO" evaluate-phrase) + +(defrule when-phrase + := "WHEN" evaluate-phrase when-phrase-also-phrase*) + +(defrule when-phrases + := when-phrase+ statement-list) + +(defrule when-other-phrase + := "WHEN" "OTHER" statement-list) + +(defrule evaluate-phrase + := "ANY" + := condition + := "TRUE" + := "FALSE" + := evaluate-phrase-1) + +(defrule evaluate-phrase-1 + := "NOT"? arithmetic-expression through-arithmetic-expression?) + +(defrule through-arithmetic-expression + := through arithmetic-expression) + +(defrule exit-statement + := "EXIT" + :reduce '(exit-paragraph)) + +(defrule exit-program-statement + := "EXIT" "PROGRAM" + :reduce '(exit-program)) + +(defrule goback-statement + := "GOBACK" + :reduce '(go-back)) + +(defrule go-to-statement + := "GO" "TO"? procedure-name+ "DEPENDING" "ON"? variable-identifier + :reduce (list 'goto-depending variable-identifier procedure-name) + := "GO" "TO"? procedure-name + :reduce (list 'goto procedure-name)) + +(defrule if-phrase + := "IF" condition "THEN"? alt-statement-list-next-sentence "ELSE" alt-statement-list-next-sentence + :reduce (list 'if condition + (if (cdr alt-statement-list-next-sentence) + (cons 'progn alt-statement-list-next-sentence) + (car alt-statement-list-next-sentence)) + (if (cdr alt-statement-list-next-sentence2) + (cons 'progn alt-statement-list-next-sentence2) + (car alt-statement-list-next-sentence2))) + := "IF" condition "THEN"? alt-statement-list-next-sentence + :reduce (append (list 'when condition) alt-statement-list-next-sentence)) + +(defrule if-statement + := if-phrase "END-IF"? + :reduce $1) + +(defrule initialize-statement + := "INITIALIZE" variable-identifier+ initialize-replacing-phrase?) + +(defrule initialize-replacing-type + := "ALPHABETIC" + := "ALPHANUMERIC" + := "NUMERIC" + := "ALPHANUMERIC-EDITED" + := "NUMERIC-EDITED" + := "DBCS" + := "EGCS") + +(defrule initialize-replacing-argument + := initialize-replacing-type "DATA"? "BY" id-or-lit) + +(defrule initialize-replacing-phrase + := "REPLACING" initialize-replacing-argument+) + +(defrule inspect-statement + := inspect-statement-1 + := inspect-statement-2 + := inspect-statement-3 + := inspect-statement-4) + +(defrule inspect-statement-1 + := "INSPECT" variable-identifier "TALLYING" tallying-argument+) + +(defrule inspect-statement-2 + := "INSPECT" variable-identifier "CONVERTING" id-or-lit "TO" id-or-lit before-after-phrase*) + +(defrule inspect-statement-3 + := "INSPECT" variable-identifier "TALLYING" tallying-argument+ "REPLACING" inspect-replacing-phrase+) + +(defrule tallying-for-id-or-lit + := id-or-lit before-after-phrase*) + +(defrule alt-all-leading + := "ALL" + := "LEADING") + +(defrule tallying-for-argument-1 + := "CHARACTERS" before-after-phrase*) + +(defrule tallying-for-argument-2 + := alt-all-leading tallying-for-id-or-lit+) + +(defrule tallying-for-argument + := tallying-for-argument-1 + := tallying-for-argument-2) + +(defrule tallying-argument + := variable-identifier "FOR" tallying-for-argument+) + +(defrule inspect-statement-4 + := "INSPECT" variable-identifier "REPLACING" inspect-replacing-phrase+) + +(defrule inspect-replacing-argument + := inspect-by-argument "BY" inspect-by-argument before-after-phrase*) + +(defrule alt-all-leading-first + := "ALL" + := "LEADING" + := "FIRST") + +(defrule inspect-replacing-phrase-1 + := "CHARACTERS" "BY" id-or-lit before-after-phrase*) + +(defrule inspect-replacing-phrase-2 + := alt-all-leading-first inspect-replacing-argument+) + +(defrule inspect-replacing-phrase + := inspect-replacing-phrase-1 + := inspect-replacing-phrase-2) + +(defrule before-after-phrase + := alt-before-after "INITIAL"? id-or-lit) + +(defrule merge-statement + := "MERGE" file-name on-key-phrase+ collating-sequence? "USING" file-name file-name+ merge-statement-tail) + +(defrule on-key-phrase + := "ON"? alt-ascending-descending "KEY"? qualified-data-name+) + +(defrule merge-statement-tail + := output-procedure + := giving-file-names) + +(defrule move-statement + := "MOVE" id-or-lit "TO" variable-identifier+ + :reduce (apply #'list 'move id-or-lit variable-identifier) + := "MOVE" corresponding variable-identifier "TO" variable-identifier+ + :reduce (apply #'list 'move-corresponding variable-identifier variable-identifier2)) + +(defrule multiply-statement + := "MULTIPLY" id-or-lit "BY" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"? + :reduce (list 'multiply id-or-lit cobword-rounded :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list) + := "MULTIPLY" id-or-lit "BY" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"? + :reduce (list 'multiply id-or-lit id-or-lit2 :giving cobword-rounded + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list)) + +(defrule open-statement + := "OPEN" open-statement-phrase+ + :reduce (list 'open open-statement-phrase)) + +(defrule alt-reversed-with-no-rewind + := "REVERSED" + := with-no-rewind) + +(defrule open-statement-input-file-name + := file-name alt-reversed-with-no-rewind?) + +(defrule with-no-rewind + := "WITH"? "NO" "REWIND") + +(defrule open-statement-output-file-name + := file-name with-no-rewind?) + +(defrule open-statement-input + := "INPUT" open-statement-input-file-name+) + +(defrule open-statement-output + := "OUTPUT" open-statement-output-file-name+) + +(defrule open-statement-i-o + := "I-O" file-name+) + +(defrule open-statement-extend + := "EXTEND" file-name+) + +(defrule open-statement-phrase + := open-statement-input + := open-statement-output + := open-statement-i-o + := open-statement-extend) + +(defrule perform-statement + := "PERFORM" procedure-name through-procedure-name? perform-until-phrase + :reduce `(perform-until ,procedure-name ,through-procedure-name ,perform-until-phrase) + := "PERFORM" procedure-name through-procedure-name? perform-varying-phrase perform-after-phrase* + :reduce `(perform-varying ,perform-varying-phrase ,procedure-name ,through-procedure-name ,perform-after-phrase) + := "PERFORM" procedure-name through-procedure-name? cobword-int "TIMES" + :reduce `(perform-times ,cobword-int ,procedure-name ,through-procedure-name) + := "PERFORM" procedure-name through-procedure-name? + :reduce (append (list 'perform procedure-name) through-procedure-name)) + +(defrule perform-varying-phrase + := with-test? "VARYING" variable-identifier "FROM" id-or-lit "BY" id-or-lit "UNTIL" condition) + +(defrule perform-after-phrase + := "AFTER" variable-identifier "FROM" id-or-lit "BY" id-or-lit "UNTIL" condition) + +(defrule perform-until-phrase + := with-test? "UNTIL" condition) + +(defrule with-test + := "WITH"? "TEST" alt-before-after + :reduce alt-before-after) + +(defrule read-statement + := "READ" file-name "NEXT"? "RECORD"? into-identifier? key-is-qualified-data-name? invalid-key-statement-list? not-invalid-key-statement-list? at-end-statement-list? not-at-end-statement-list? "END-READ"?) + +(defrule key-is-qualified-data-name + := "KEY" "IS"? qualified-data-name) + +(defrule release-statement + := "RELEASE" record-name from-identifier?) + +(defrule return-statement + := "RETURN" file-name "RECORD"? into-identifier? "AT"? "END" statement-list not-at-end-statement-list? "END-RETURN"?) + +(defrule into-identifier + := "INTO" variable-identifier) + +(defrule not-at-end-statement-list + := "NOT" "AT"? "END" statement-list) + +(defrule rewrite-statement + := "REWRITE" record-name from-identifier? invalid-key-statement-list? not-invalid-key-statement-list? "END-REWRITE"?) + +(defrule search-statement + := search-statement-1 + := search-statement-2) + +(defrule search-statement-1 + := "SEARCH" cobol-identifier varying-identifier? at-end-statement-list? when-condition-stats+ "END-SEARCH"?) + +(defrule varying-identifier + := "VARYING" variable-identifier) + +(defrule when-condition-stats + := "WHEN" condition alt-statement-list-next-sentence) + +(defrule search-statement-2 + := "SEARCH" "ALL" variable-identifier at-end-statement-list? "WHEN" search-statement-condition search-statement-condition-tail* alt-statement-list-next-sentence "END-SEARCH"?) + +(defrule at-end-statement-list + := "AT"? "END" statement-list) + +(defrule search-statement-equal-expression + := variable-identifier "IS"? equal-to arithmetic-expression + :reduce (list '= variable-identifier arithmetic-expression)) + +(defrule search-statement-condition + := search-statement-equal-expression + := condition-name-reference) + +(defrule search-statement-condition-tail + := "AND" search-statement-condition) + +(defrule alt-statement-list-next-sentence + := statement+ + := next-sentence + :reduce :next-sentence) + +(defrule set-statement + := "SET" set-statement-phrase+) + +(defrule sort-statement + := "SORT" file-name on-key-is-phrase+ with-duplicates-in-order? collating-sequence? sort-statement-in sort-statement-out) + +(defrule key-is + := "KEY" "IS"?) + +(defrule alt-ascending-descending + := "ASCENDING" + := "DESCENDING") + +(defrule on-key-is-phrase + := "ON"? alt-ascending-descending key-is? qualified-data-name+) + +(defrule with-duplicates-in-order + := "WITH"? "DUPLICATES" "IN"? "ORDER"?) + +(defrule collating-sequence + := "COLLATING"? "SEQUENCE" "IS"? alphabet-name) + +(defrule through + := "THROUGH" + := "THRU") + +(defrule through-procedure-name + := through procedure-name + :reduce procedure-name) + +(defrule using-file-names + := "USING" file-name+) + +(defrule input-procedure + := "INPUT" "PROCEDURE" "IS"? procedure-name through-procedure-name?) + +(defrule giving-file-names + := "GIVING" file-name+) + +(defrule output-procedure + := "OUTPUT" "PROCEDURE" "IS"? procedure-name through-procedure-name?) + +(defrule sort-statement-in + := using-file-names + := input-procedure) + +(defrule sort-statement-out + := giving-file-names + := output-procedure) + +(defrule start-statement + := "START" file-name key-is-rel-op-qualified-data-name? invalid-key-statement-list? not-invalid-key-statement-list? "END-START"?) + +(defrule rel-op + := equal-to + :reduce '= + := greater-than + :reduce '> + := greater-equal + :reduce '>=) + +(defrule key-is-rel-op-qualified-data-name + := "KEY" "IS"? rel-op qualified-data-name + :reduce (list rel-op qualified-data-name)) + +(defrule stop-statement + := "STOP" alt-run-literal + :reduce '(stop)) + +(defrule alt-run-literal + := "RUN" + := literal) + +(defrule string-statement + := "STRING" delimited-by-phrase+ "INTO" variable-identifier with-pointer-identifier? on-overflow-statement-list? not-on-overflow-statement-list? "END-STRING"? + :reduce (list 'string-concat delimited-by-phrase variable-identifier :with-pointer with-pointer-identifier :on-overflow on-overflow-statement-list :not-on-overflow not-on-overflow-statement-list)) + +(defrule id-or-lit-size + := literal + := variable-identifier + := "SIZE") + +(defrule delimited-by-phrase + := id-or-lit+ "DELIMITED" "BY"? id-or-lit-size + :reduce (list id-or-lit id-or-lit-size)) + +(defrule subtract-statement + := "SUBTRACT" id-or-lit+ "FROM" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? + :reduce (list 'subtract-giving id-or-lit id-or-lit2 cobword-rounded + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list) + := "SUBTRACT" id-or-lit+ "FROM" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? + :reduce (list 'subtract id-or-lit cobword-rounded + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list) + := "SUBTRACT" corresponding variable-identifier "FROM" variable-identifier "ROUNDED"? on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? + :reduce (list 'subtract-corr variable-identifier variable-identifier + :rounded (and $5 t) + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list)) + +(defrule cobword-rounded + := variable-identifier "ROUNDED"? + :reduce (list variable-identifier (and $2 t))) + +(defrule on-size-error-statement-list + := "ON"? "SIZE" "ERROR" statement-list + :reduce statement-list) + +(defrule not-on-size-error-statement-list + := "NOT" "ON"? "SIZE" "ERROR" statement-list + :reduce statement-list) + +(defrule corresponding + := "CORRESPONDING" + := "CORR") + +(defrule unstring-statement + := "UNSTRING" variable-identifier delimited-by-all-phrase? "INTO" unstring-statement-dst+ with-pointer-identifier? tallying-in-identifier? on-overflow-statement-list? not-on-overflow-statement-list? "END-UNSTRING"? + :reduce (list 'unstring variable-identifier unstring-statement-dst + :delimited-by-all delimited-by-all-phrase + :with-pointer with-pointer-identifier + :tallying tallying-in-identifier + :on-overflow on-overflow-statement-list + :not-on-overflow not-on-overflow-statement-list)) + +(defrule id-or-lit + := literal + := variable-identifier) + +(defrule or-all-id-or-lit + := "OR" "ALL"? id-or-lit) + +(defrule delimited-by-all-phrase + := "DELIMITED" "BY"? "ALL"? id-or-lit or-all-id-or-lit*) + +(defrule delimiter-in-identifier + := "DELIMITER" "IN"? variable-identifier) + +(defrule count-in-identifier + := "COUNT" "IN"? variable-identifier) + +(defrule unstring-statement-dst + := variable-identifier delimiter-in-identifier? count-in-identifier?) + +(defrule with-pointer-identifier + := "WITH"? "POINTER" variable-identifier) + +(defrule tallying-in-identifier + := "TALLYING" "IN"? variable-identifier) + +(defrule on-overflow-statement-list + := "ON"? "OVERFLOW" statement-list) + +(defrule not-on-overflow-statement-list + := "NOT" "ON"? "OVERFLOW" statement-list) + +(defrule write-statement + := "WRITE" record-name from-identifier? advancing-phrase? write-exceptions "END-WRITE"?) + +(defrule lines + := "LINE" + := "LINES") + +(defrule cobword-int + := cobol-identifier + := integer) + +(defrule nr-lines-phrase + := cobword-int lines?) + +(defrule page-phrase + := nr-lines-phrase + := "PAGE") + +(defrule alt-before-after + := "BEFORE" + := "AFTER") + +(defrule advancing-phrase + := alt-before-after "ADVANCING"? page-phrase) + +(defrule from-identifier + := "FROM" variable-identifier) + +(defrule invalid-key-statement-list + := "INVALID" "KEY"? statement-list + :reduce statement-list) + +(defrule not-invalid-key-statement-list + := "NOT" "INVALID" "KEY"? statement-list + :reduce statement-list) + +(defrule end-of-page + := "END-OF-PAGE" + := "EOP") + +(defrule at-end-of-page-statement-list + := "AT"? end-of-page statement-list + :reduce statement-list) + +(defrule not-at-end-of-page-statement-list + := "NOT" "AT"? end-of-page statement-list + :reduce statement-list) + +;; This is left in the grammar but is not used. COPYs are handled by +;; the lexical scanner. +(defrule copy-statement + := "COPY" alt-text-name-literal in-library? "SUPPRESS"? copy-statement-replacing-phrase?) + +(defrule in + := "OF" + := "IN") + +(defrule alt-library-name-literal + := library-name + := literal) + +(defrule in-library + := in alt-library-name-literal) + +(defrule copy-statement-by-phrase + := copy-operand "BY" copy-operand) + +(defrule copy-statement-replacing-phrase + := "REPLACING" copy-statement-by-phrase+) + +(defrule alt-text-name-literal + := text-name + := literal) + +(defrule copy-operand + := cobol-identifier + := literal) + +(defrule use-statement + := use-statement-1 + := use-statement-2 + := use-statement-3) + +(defrule use-statement-1 + := "USE" "GLOBAL"? "AFTER" "STANDARD"? alt-exception-error "PROCEDURE" "ON"? alt-file-names-i-o) + +(defrule alt-exception-error + := "EXCEPTION" + := "ERROR") + +(defrule use-statement-2 + := "USE" "GLOBAL"? "AFTER" "STANDARD"? alt-beginning-ending? alt-file-reel-unit? "LABEL" "PROCEDURE" "ON"? alt-file-names-i-o) + +(defrule alt-beginning-ending + := "BEGINNING" + := "ENDING") + +(defrule alt-file-reel-unit + := "FILE" + := "REEL" + := "UNIT") + +(defrule file-names + := file-name+) + +(defrule alt-file-names-i-o + := file-names + := "INPUT" + := "OUTPUT" + := "I-O" + := "EXTEND") + +(defrule use-statement-3 + := "USE" "FOR"? "DEBUGGING" "ON"? alt-procedures-all-procedures) + +(defrule procedure-names + := procedure-name+) + +(defrule alt-procedures-all-procedures + := procedure-names + := all-procedures) + +(defrule condition + := combinable-condition + := combinable-condition "AND" condition + :reduce `(and ,combinable-condition ,condition) + := combinable-condition "OR" condition + :reduce `(or ,combinable-condition ,condition) + := combinable-condition "AND" id-or-lit + :reduce `(and ,combinable-condition (,(car combinable-condition) ,(cadr combinable-condition) ,id-or-lit)) + := combinable-condition "OR" id-or-lit + :reduce `(or ,combinable-condition (,(car combinable-condition) ,(cadr combinable-condition) ,id-or-lit))) + +(defrule combinable-condition + := "NOT"? simple-condition + :reduce (if $1 + (list 'not simple-condition) + simple-condition)) + +(defrule simple-condition + := class-condition + := relation-condition + := sign-condition + := "(" condition ")" + ;; not sure if it's necessary -wcp15/7/03. + ;; := arithmetic-expression + ) + +(defrule class-condition + := variable-identifier "IS"? "NOT"? class-type + :reduce (if $3 + (list 'not (list 'type-of variable-identifier (make-keyword class-type))) + (list 'type-of variable-identifier (make-keyword class-type)))) + +(defrule class-type + := "NUMERIC" + := "ALPHABETIC" + := "ALPHABETIC-LOWER" + := "ALPHABETIC-UPPER" + := "DBCS") + +(defun unfold-subrelations (main-relation subs) + (destructuring-bind (main-operator main-variable other-variable) main-relation + (declare (ignore other-variable)) + (labels ((unfold (subs) + (if (null subs) + main-relation + (destructuring-bind (connection operator variable) (car subs) + (list connection + (list (or operator main-operator) main-variable variable) + (unfold (cdr subs))))))) + (unfold subs)))) + +(defrule relation-condition + ;; This is too complex + ;; := arithmetic-expression relational-operator simple-condition + := id-or-lit relational-operator id-or-lit subordinate-relation* + :reduce (unfold-subrelations (list relational-operator id-or-lit id-or-lit2) subordinate-relation)) + +(defrule or-and + := "OR" :reduce 'or + := "AND" :reduce 'and) + +(defrule subordinate-relation + := or-and relational-operator? id-or-lit + :reduce (list or-and relational-operator id-or-lit)) + +(defrule relational-operator + := "IS"? relational-operator-type + :reduce relational-operator-type) + +(defrule less-than + := "LESS" "THAN"? + := "<") + +(defrule greater-equal + := "GREATER" "THAN"? "OR" "EQUAL" "TO"? + := ">=" + := ">" "=" + := "NOT" "<" + := "NOT" "LESS" "THAN"?) + +(defrule less-equal + := "LESS" "THAN"? "OR" "EQUAL" "TO"? + := "<=" + := "<" "=" + := "NOT" ">" + := "NOT" "GREATER" "THAN"?) + +(defrule greater-than + := "GREATER" "THAN"? + := ">") + +(defrule equal-to + := "EQUAL" "TO"? + := "=") + +(defrule relational-operator-type + := greater-equal + :reduce 'cob>= + := less-equal + :reduce 'cob<= + := greater-than + :reduce 'cob> + := less-than + :reduce 'cob< + := equal-to + :reduce 'cob= + := "NOT" equal-to + :reduce 'cob-not=) + +(defrule sign-condition + := arithmetic-expression "IS"? "NOT"? sign-type + :reduce (if $3 + `(not (,sign-type ,arithmetic-expression)) + `(,sign-type ,arithmetic-expression))) + +(defrule sign-type + := "POSITIVE" :reduce '> + := "NEGATIVE" :reduce '< + := "ZERO" :reduce '= + := "ZEROES" :reduce '= + := "ZEROS" :reduce '=) + +(defrule procedure-name + := paragraph-or-section-name in-section-name + :reduce (list paragraph-or-section-name in-section-name) + := paragraph-or-section-name + :reduce paragraph-or-section-name) + +(defrule in-section-name + := in cobol-identifier + :reduce cobol-identifier) + +(defrule variable-identifier + := qualified-data-name subscript-parentheses* ;; reference-modification? + :reduce (if subscript-parentheses + (list :aref qualified-data-name subscript-parentheses) + qualified-data-name)) + +(defrule reference-modification + := "(" leftmost-character-position ":" length? ")" + :reduce (if length + (list :range leftmost-character-position length) + leftmost-character-position)) + +(defrule condition-name-reference + := condition-name in-data-or-file-or-mnemonic-name* subscript-parentheses*) + +(defrule in-data-or-file-or-mnemonic-name + := in data-or-file-or-mnemonic-name) + +(defrule subscript-parentheses + := "(" subscript ")") + +(defrule subscript + := subscript-expression+) + +(defrule plus-minus-integer + := plus-or-minus integer) + +(defrule subscript-expression-ambiguous + := qualified-data-name plus-minus-integer?) + +(defrule subscript-expression + := literal + := subscript-expression-ambiguous) + +(defrule qualified-data-name + := data-name in-data-or-file-name* + :reduce (if in-data-or-file-name + (list data-name in-data-or-file-name) ; incomplete -wcp15/7/03. + data-name) + := "ADDRESS" "OF" data-name + :reduce (list 'address-of data-name) + := "LENGTH" "OF" cobol-identifier + :reduce (list 'length-of cobol-identifier)) + +(defrule in-data-or-file-name + := in data-or-file-name) + +(defrule leftmost-character-position + := arithmetic-expression) + +(defrule length + := arithmetic-expression) + +(defrule arithmetic-expression + := times-div + := times-div "+" arithmetic-expression + :reduce `(+ ,times-div ,arithmetic-expression) + := times-div "-" arithmetic-expression + :reduce `(- ,times-div ,arithmetic-expression)) + +(defrule times-div + := power + := power "*" times-div + :reduce `(* ,power ,times-div) + := power "/" times-div + :reduce `(/ ,power ,times-div)) + +(defrule power + := plus-or-minus? basis + := plus-or-minus? basis "**" power + :reduce (if plus-or-minus + `(plus-or-minus (expt basis basis2)) + `(expt basis basis2))) + +(defrule plus-or-minus + := "+" + :reduce '+ + := "-" + :reduce '-) + +;; (defrule power-tail +;; := "**" basis) + +(defrule basis + := literal + := variable-identifier + := "(" arithmetic-expression ")") + +(defrule alphabet-name + := cobol-identifier) + +(defrule condition-name + := cobol-identifier) + +(defrule data-name + := cobol-identifier) + +(defrule cobol-identifier + := identifier + :reduce (intern (string-upcase identifier))) + +(defrule file-name + := cobol-identifier) + +(defrule data-or-file-name + := cobol-identifier) + +(defrule index-name + := cobol-identifier) + +(defrule mnemonic-name + := cobol-identifier) + +(defrule data-or-file-or-mnemonic-name + := cobol-identifier) + +(defrule record-name + := qualified-data-name) + +(defrule symbolic-character + := cobol-identifier) + +(defrule library-name + := cobol-identifier) + +(defrule program-name + := cobol-identifier + := string) + +(defrule text-name + := cobol-identifier) + +(defrule paragraph-or-section-name + := cobol-identifier + := integer) + +(defrule computer-name + := identifier) + +(defrule environment-name + := cobol-identifier) + +(defrule assignment-name + := cobol-identifier) + +(defrule figurative-constant + := figurative-constant-simple + := figurative-constant-all) + +(defrule figurative-constant-all + := "ALL" literal) + +(defrule literal + := string + := float + := integer + := figurative-constant) + +) ; defun populate-grammar diff --git a/third_party/lisp/npg/npg.asd b/third_party/lisp/npg/npg.asd new file mode 100644 index 0000000000..1e35186d6c --- /dev/null +++ b/third_party/lisp/npg/npg.asd @@ -0,0 +1,55 @@ +;;; npg.asd --- declaration of this system + +;;; Copyright (C) 2003, 2006 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: npg.asd, Time-stamp: <2006-01-03 17:20:21 wcp> $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(defpackage :npg-system + (:use :common-lisp :asdf)) + +(in-package :npg-system) + +(defclass sample-file (doc-file) ()) +(defmethod source-file-type ((c sample-file) (s module)) + "lisp") + +(defsystem npg + :name "NPG" + :author "Walter C. Pelissero <walter@pelissero.de>" + :maintainer "Walter C. Pelissero <walter@pelissero.de>" + :licence "Lesser General Public License" + :description "NPG a Naive Parser Generator" + :long-description + "NPG is a backtracking recursive descent parser generator for +Common Lisp. It accepts rules in a Lispy EBNF syntax without indirect +left recursive rules." + :components + ((:doc-file "README") + (:doc-file "COPYING") + (:doc-file ".project") + (:module :examples + :components + ((:sample-file "python") + (:sample-file "vs-cobol-ii"))) + (:module :src + :components + ((:file "package") + (:file "common" :depends-on ("package")) + (:file "define" :depends-on ("package" "common")) + (:file "parser" :depends-on ("package" "common")))))) diff --git a/third_party/lisp/npg/src/common.lisp b/third_party/lisp/npg/src/common.lisp new file mode 100644 index 0000000000..8b64f5cc0a --- /dev/null +++ b/third_party/lisp/npg/src/common.lisp @@ -0,0 +1,79 @@ +;;; common.lisp --- common stuff + +;;; Copyright (C) 2003-2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: common.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :naive-parser-generator) + +(eval-when (:compile-toplevel :load-toplevel) + (defstruct grammar + rules + keywords + equal-p) + + (defstruct rule + name + productions) + + (defstruct (production (:conc-name prod-)) + tokens + (tokens-length 0 :type fixnum) + action) + + (defstruct token + type ; type of token (identifier, number, ...) + value ; its actual value + position) ; line/column in the input stream + ) ; eval-when + +(defmethod print-object ((obj rule) stream) + (format stream "#R(~A)" (rule-name obj))) + +(defmethod print-object ((obj production) stream) + (format stream "#P(action: ~S)" (prod-action obj))) + +(defmethod print-object ((obj token) stream) + (format stream "#T:~A=~S" (token-type obj) (token-value obj))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declaim (inline make-rules-table find-rule add-rule)) + +(defun make-rules-table () + (make-hash-table)) + +(defun find-rule (rule-name rules) + (gethash rule-name rules)) + +(defun add-rule (rule-name rule rules) + (setf (gethash rule-name rules) rule)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declaim (inline make-keywords-table find-keyword add-keyword)) + +(defun make-keywords-table () + (make-hash-table :test 'equal)) + +(defun find-keyword (keyword-name keywords) + (gethash keyword-name keywords)) + +(defun add-keyword (keyword keywords) + (setf (gethash keyword keywords) t)) diff --git a/third_party/lisp/npg/src/define.lisp b/third_party/lisp/npg/src/define.lisp new file mode 100644 index 0000000000..783f071fc5 --- /dev/null +++ b/third_party/lisp/npg/src/define.lisp @@ -0,0 +1,408 @@ +;;; define.lisp --- grammar rules definition + +;;; Copyright (C) 2003-2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: define.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :naive-parser-generator) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *smart-default-reduction* t + "If true the default reductions take only the non-static tokens - +those that are not declared as strings in the grammar.") + +;; These two are filled with DEFRULE. +(defvar *rules* (make-rules-table)) +(defvar *keywords* (make-keywords-table)) + +(defun make-action-arguments (tokens) + "Given a list of tokens making up a production, return three values: +the list of variables for the function reducing this production, those +that are non static and their unambiguous user-friendly names." + (flet ((unique (sym list) + (if (not (assoc sym list)) + sym + (loop + for i of-type fixnum from 2 + for x = (intern (format nil "~:@(~A~)~A" sym i)) + while (assoc x list) + finally (return x))))) + (loop + for tok in tokens + for i of-type fixnum from 1 + for arg = (intern (format nil "$~A" i) (find-package #.*package*)) + collect arg into args + unless (const-terminal-p tok) + collect arg into vars + and when (symbolp tok) + collect (list (unique tok named-vars) arg) into named-vars + when (and (listp tok) + (symbolp (cadr tok))) + collect (list (unique (cadr tok) named-vars) arg) into named-vars + finally + (return (values args vars named-vars))))) + +(defun make-action-function (name tokens action) + "Create a function with name NAME, arguments derived from TOKENS and +body ACTION. Return it's definition." + (let ((function + (multiple-value-bind (args vars named-vars) + (make-action-arguments tokens) + `(lambda ,args + (declare (ignorable ,@args)) + (let (($vars (list ,@vars)) + ($all (list ,@args)) + ,@named-vars + ($alist (list ,@(mapcar #'(lambda (v) + `(cons ',(intern (symbol-name (car v))) + ,(cadr v))) + named-vars)))) + (declare (ignorable $vars $all $alist ,@(mapcar #'car named-vars))) + (flet ((make-object (&optional type args) + (apply #'make-instance (or type ',name) + (append args $alist)))) + ,action)))))) + (when *compile-print* + (if *compile-verbose* + (format t "; Compiling ~S:~% ~S~%" name function) + (format t "; Compiling ~S~%" name))) + (compile name function))) + +(defun define-rule (name productions) + "Accept a rule in EBNF-like syntax, translate it into a sexp and a +call to INSERT-RULE-IN-CURRENT-GRAMMAR." + (flet ((transform (productions) + (loop + for tok in productions + with prod = nil + with action = nil + with phase = nil + with new-prods = nil + while tok + do (cond ((eq tok :=) + (push (list (nreverse prod) action) new-prods) + (setf prod nil + action nil + phase :prod)) + ((eq tok :reduce) + (setf phase :action)) + ((eq tok :tag) + (setf phase :tag)) + ((eq phase :tag) + (setf action `(cons ,tok $vars))) + ((eq phase :action) + (setf action tok)) + ((eq phase :prod) + (push tok prod))) + finally + (return (cdr (nreverse (cons (list (nreverse prod) action) new-prods))))))) + (insert-rule-in-current-grammar name (transform productions)))) + +(defmacro defrule (name &rest productions) + "Wrapper macro for DEFINE-RULE." + `(define-rule ',name ',productions)) + +(defun make-optional-rule (token) + "Make a rule for a possibly missing (non)terminal (? syntax) and +return it." + (insert-rule-in-current-grammar + (gensym (concatenate 'string "OPT-" + (if (rule-p token) + (symbol-name (rule-name token)) + (string-upcase token)))) + `(((,token)) (())))) + +(defun make-alternative-rule (tokens) + "Make a rule for a list of alternatives (\"or\" syntax) and return it." + (insert-rule-in-current-grammar + (gensym "ALT") + (mapcar #'(lambda (alternative) + `((,alternative))) + tokens))) + +(defun make-nonempty-list-rule (token &optional separator) + "Make a rule for a non-empty list (+ syntax) and return it." + (let ((rule-name (gensym (concatenate 'string "NELST-" + (if (rule-p token) + (symbol-name (rule-name token)) + (string-upcase token)))))) + (insert-rule-in-current-grammar + rule-name + (if separator + `(((,token ,separator ,rule-name) + (cons $1 $3)) + ((,token) ,#'list)) + `(((,token ,rule-name) + (cons $1 $2)) + ((,token) ,#'list)))))) + +(defun make-list-rule (token &optional separator) + "Make a rule for a possibly empty list (* syntax) return it." + (make-optional-rule (make-nonempty-list-rule token separator))) + +(defun const-terminal-p (object) + (or (stringp object) + (keywordp object))) + +(defun expand-production-token (tok) + "Translate token of the type NAME? or NAME* or NAME+ into (? NAME) +or (* NAME) or (+ NAME). This is used by the DEFRULE macro." + (if (symbolp tok) + (let* ((name (symbol-name tok)) + (last (char name (1- (length name)))) + ;; this looks silly but we need to make sure that we + ;; return symbols interned in this package, no one else + (op (cadr (assoc last '((#\? ?) (#\+ +) (#\* *)))))) + (if (and (> (length name) 1) op) + (list op + (intern (subseq name 0 (1- (length name))))) + tok)) + tok)) + +(defun EBNF-to-SEBNF (tokens) + "Take a production as a list of TOKENS and expand it. This turns a +EBNF syntax into a sexp-based EBNF syntax or SEBNF." + (loop + for tok in tokens + for token = (expand-production-token tok) + with new-tokens = '() + do (cond ((member token '(* + ?)) + (setf (car new-tokens) + (list token (car new-tokens)))) + (t + (push token new-tokens))) + finally (return (nreverse new-tokens)))) + +(defun SEBNF-to-BNF (tokens) + "Take a production in SEBNF (Symbolic Extended BNF) syntax and turn +it into BNF. The production is simplified but the current grammar is +populated with additional rules." + (flet ((make-complex-token-rule (tok) + (ecase (car tok) + (* (apply #'make-list-rule (cdr tok))) + (+ (apply #'make-nonempty-list-rule (cdr tok))) + (? (make-optional-rule (cadr tok))) + (or (make-alternative-rule (cdr tok)))))) + (loop + for token in tokens + with new-tokens = '() + with keywords = '() + do (cond ((listp token) + (push (make-complex-token-rule token) new-tokens)) + (t + (push token new-tokens) + (when (const-terminal-p token) + (push token keywords)))) + finally (return (values (nreverse new-tokens) keywords))))) + +(defun make-default-action-function (name tokens) + "Create a sexp to be used as default action in case one is not +supplied in the production. This is usually a quite sensible +one. That is, only the non-constant tokens are returned in a +list and in case only a variable token is available that one is +returned (not included in a list). If all the tokens are +constant, then all of them are returned in a list." + (cond ((null tokens) + ;; if the production matched the empty list (no tokens) we + ;; return always nil, that is the function LIST applied to no + ;; arguments + #'list) + ((null (cdr tokens)) + ;; if the production matches just one token we simply return + ;; that + #'identity) + (*smart-default-reduction* + ;; If we are required to be "smart" then create a function + ;; that simply returns the non static tokens of the + ;; production. If the production doesn't have nonterminal, + ;; then return all the tokens. If the production has only + ;; one argument then return that one only. + (make-action-function name tokens '(cond + ((null $vars) $all) + ((null (cdr $vars)) (car $vars)) + (t $vars)))) + (t + ;; in all the other cases we return all the token matching + ;; the production + #'list))) + +(defun make-production-from-descr (name production-description) + "Take a production NAME and its description in the form of a sexp +and return a production structure object together with a list of used +keywords." + (destructuring-bind (tokens &optional action) production-description + (let ((expanded-tokens (EBNF-to-SEBNF tokens))) + (multiple-value-bind (production-tokens keywords) + (sebnf-to-bnf expanded-tokens) + (let ((funct + (cond ((not action) + (make-default-action-function name expanded-tokens)) + ((or (listp action) + ;; the case when the action is simply to + ;; return a token (ie $2) or a constant value + (symbolp action)) + (make-action-function name expanded-tokens action)) + ((functionp action) + action) + (t ; action is a constant + #'(lambda (&rest args) + (declare (ignore args)) + action))))) + (values + ;; Make a promise instead of actually resolving the + ;; nonterminals. This avoids endless recursion. + (make-production :tokens production-tokens + :tokens-length (length production-tokens) + :action funct) + keywords)))))) + +(defun remove-immediate-left-recursivity (rule) + "Turn left recursive rules of the type + A -> A x | y +into + A -> y A2 + A2 -> x A2 | E +where E is the empty production." + (let ((name (rule-name rule)) + (productions (rule-productions rule))) + (loop + for prod in productions + for tokens = (prod-tokens prod) + ;; when immediately left recursive + when (eq (car tokens) rule) + collect prod into left-recursive + else + collect prod into non-left-recursive + finally + ;; found any left recursive production? + (when left-recursive + (warn "rule ~S is left recursive" name) + (let ((new-rule (make-rule :name (gensym "REWRITE")))) + ;; A -> y A2 + (setf (rule-productions rule) + (mapcar #'(lambda (p) + (let ((tokens (prod-tokens p)) + (action (prod-action p))) + (make-production :tokens (append tokens (list new-rule)) + :tokens-length (1+ (prod-tokens-length p)) + :action #'(lambda (&rest args) + (let ((f-A2 (car (last args))) + (head (butlast args))) + (funcall f-A2 (apply action head))))))) + non-left-recursive)) + ;; A2 -> x A2 | E + (setf (rule-productions new-rule) + (append + (mapcar #'(lambda (p) + (let ((tokens (prod-tokens p)) + (action (prod-action p))) + (make-production :tokens (append (cdr tokens) (list new-rule)) + :tokens-length (prod-tokens-length p) + :action #'(lambda (&rest args) + (let ((f-A2 (car (last args))) + (head (butlast args))) + #'(lambda (x) + (funcall f-A2 (apply action x head)))))))) + left-recursive) + (list + (make-production :tokens nil + :tokens-length 0 + :action #'(lambda () #'(lambda (arg) arg))))))))))) + +(defun remove-left-recursivity-from-rules (rules) + (loop + for rule being each hash-value in rules + do + ;; More to be done here. For now only the trivial immediate left + ;; recursivity is removed -wcp18/11/03. + (remove-immediate-left-recursivity rule))) + +(defun resolve-all-nonterminals (rules) + (loop + for rule being each hash-value in rules + do (loop + for production in (rule-productions rule) + do (setf (prod-tokens production) + (resolve-nonterminals (prod-tokens production) rules))))) + +(defun make-rule-productions (rule-name production-descriptions) + "Return a production object that belongs to RULE-NAME made according +to PRODUCTION-DESCRIPTIONS. See also MAKE-PRODUCTION-FROM-DESCR." + (loop + for descr in production-descriptions + for i of-type fixnum from 1 by 1 + for prod-name = (intern (format nil "~:@(~A~)-PROD~A" rule-name i)) + with productions = '() + with keywords = '() + do (progn + (multiple-value-bind (production keyws) + (make-production-from-descr prod-name descr) + (push production productions) + (setf keywords (append keyws keywords)))) + finally (return + (values (nreverse productions) keywords)))) + +(defun create-rule (name production-descriptions) + "Return a new rule object together with a list of keywords making up +the production definitions." + (multiple-value-bind (productions keywords) + (make-rule-productions name production-descriptions) + (values (make-rule :name name :productions productions) + keywords))) + +(defun insert-rule-in-current-grammar (name productions) + "Add rule to the current grammar and its keywords to the keywords +hash table. You don't want to use this directly. See DEFRULE macro +instead." + (when (find-rule name *rules*) + (error "redefining rule ~A" name)) + (multiple-value-bind (rule keywords) + (create-rule name productions) + (add-rule name rule *rules*) + (dolist (term keywords) + (add-keyword term *keywords*)) + rule)) + +(defun resolve-nonterminals (tokens rules) + "Given a list of production tokens, try to expand the nonterminal +ones with their respective rule from the the RULES pool." + (flet ((resolve-symbol (sym) + (or (find-rule sym rules) + sym))) + (mapcar #'(lambda (tok) + (if (symbolp tok) + (resolve-symbol tok) + tok)) + tokens))) + +(defun reset-grammar () + "Empty the current grammar from any existing rule." + (setf *rules* (make-rules-table) + *keywords* (make-keywords-table))) + +(defun generate-grammar (&optional (equal-p #'string-equal)) + "Return a GRAMMAR structure suitable for the PARSE function, using +the current rules. EQUAL-P, if present, is a function to be used to +match the input tokens; it defaults to STRING-EQUAL." + (resolve-all-nonterminals *rules*) + (remove-left-recursivity-from-rules *rules*) + (make-grammar :rules *rules* + :keywords *keywords* + :equal-p equal-p)) diff --git a/third_party/lisp/npg/src/package.lisp b/third_party/lisp/npg/src/package.lisp new file mode 100644 index 0000000000..b405f7b5f1 --- /dev/null +++ b/third_party/lisp/npg/src/package.lisp @@ -0,0 +1,50 @@ +;;; package.lisp --- backtracking parser package definition + +;;; Copyright (C) 2003-2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: package.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :cl-user) + +(defpackage :naive-parser-generator + (:nicknames :npg) + (:use :common-lisp) + (:export + #:parse ; The Parser + #:reset-grammar + #:generate-grammar + #:print-grammar-figures + #:grammar-keyword-p + #:keyword + #:grammar + #:make-token + #:token-value + #:token-type + #:token-position + #:later-position + #:defrule ; to define grammars + #:deftoken ; to define a lexer + #:input-cursor-mixin + #:copy-input-cursor-slots + #:dup-input-cursor + #:read-next-tokens + #:end-of-input + #:? #:+ #:* #:or + #:$vars #:$all #:$alist + #:$1 #:$2 #:$3 #:$4 #:$5 #:$6 #:$7 #:$8 #:$9 #:$10)) diff --git a/third_party/lisp/npg/src/parser.lisp b/third_party/lisp/npg/src/parser.lisp new file mode 100644 index 0000000000..c15d26fe39 --- /dev/null +++ b/third_party/lisp/npg/src/parser.lisp @@ -0,0 +1,234 @@ +;;; parser.lisp --- runtime parser + +;;; Copyright (C) 2003-2006, 2009 by Walter C. Pelissero + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: NPG a Naive Parser Generator + +#+cmu (ext:file-comment "$Module: parser.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +;;; Commentary: +;;; +;;; This is the runtime part of the parser. The code that is +;;; responsible to execute the parser defined with the primitives +;;; found in define.lisp. + +(in-package :naive-parser-generator) + +(defvar *debug* nil + "Either nil or a stream where to write the debug informations.") +#+debug (declaim (fixnum *maximum-recursion-depth*)) +#+debug (defvar *maximum-recursion-depth* 1000 + "Maximum depth the parser is allowed to recursively call itself. +This is the only way for the parser to detect a loop in the grammar. +Tune this if your grammar is unusually complex.") + +(declaim (inline reduce-production)) +(defun reduce-production (production arguments) + "Apply PRODUCTION's action on ARGUMENTS. This has the effect of + \"reducing\" the production." + (when *debug* + (format *debug* "reducing ~S on ~S~%" production arguments)) + (flet ((safe-token-value (token) + (if (token-p token) + (token-value token) + token))) + (apply (prod-action production) (mapcar #'safe-token-value arguments)))) + +(defgeneric later-position (pos1 pos2) + (:documentation + "Compare two file postions and return true if POS1 is later than +POS2 in the input stream.")) + +;; This is meant to be overloaded in the lexer +(defmethod later-position ((pos1 integer) (pos2 integer)) + (> pos1 pos2)) + +;; this looks silly but turns out to be useful (see below) +(defmethod later-position (pos1 pos2) + (and (eq pos1 :eof) (not (eq pos2 :eof)))) + +(defgeneric read-next-tokens (tokens-source) + (:documentation "Read next token from a lexical analysed stream. The nature of +TOKENS-SOURCE is implementation dependent and any lexical analyzer is +supposed to specialise this method.")) + +;; This is the actual parser. the algorithm is pretty +;; straightforward, the execution of the reductions a bit less. Error +;; recovery is rather clumsy. + +(defun parse (grammar start tokenizer) + "Match a GRAMMAR against the list of input tokens coming from TOKENIZER. +Return the reduced values according to the nonterminal actions. Raise +an error on failure." + (declare (type grammar grammar) + (type symbol start)) + (labels + ((match-token (expected token) + (when *debug* + (format *debug* "match-token ~S ~S -> " expected token)) + (let ((res (cond ((symbolp expected) + ;; non-costant terminal (like identifiers) + (eq expected (token-type token))) + ((and (stringp expected) + (stringp (token-value token))) + ;; string costant terminal + (funcall (the function (grammar-equal-p grammar)) expected (token-value token))) + ((functionp expected) + ;; custom equality predicate (must be able + ;; to deal with token objects) + (funcall expected token)) + ;; all the rest + (t (equal expected (token-value token)))))) + (when *debug* + (format *debug* "~Amatched~%" (if res "" "not "))) + res)) + (match (expected matched #+debug depth) + (declare (list expected matched) + #+debug (fixnum depth)) + (let ((first-expected (car expected))) + (cond #+debug ((> depth *maximum-recursion-depth*) + (error "endless recursion on ~A ~A at ~A expecting ~S" + (token-type (car matched)) (token-value (car matched)) + (token-position (car matched)) expected)) + ((eq first-expected :any) + (match (cdr expected) (cdr matched) #+debug depth)) + ;; This is a trick to obtain partial parses. When we + ;; reach this expected token we assume we succeeded + ;; the parsing and return the remaining tokens as + ;; part of the match. + ((eq first-expected :rest) + ;; we could be at the end of input so we check this + (unless (cdr matched) + (setf (cdr matched) (list :rest))) + (list nil nil)) + ((rule-p first-expected) + ;; If it's a rule, then we try to match all its + ;; productions. We return the first that succeeds. + (loop + for production in (rule-productions first-expected) + for production-tokens of-type list = (prod-tokens production) + with last-error-position = nil + with last-error = nil + for (error-position error-descr) = + (progn + (when *debug* + (format *debug* "trying to match ~A: ~S~%" + (rule-name first-expected) production-tokens)) + (match (append production-tokens (cdr expected)) matched #+debug (1+ depth))) + do (cond ((not error-position) + (return (let ((args-count (prod-tokens-length production))) + (setf (cdr matched) + (cons (reduce-production + production + (subseq (the list (cdr matched)) 0 args-count)) + (nthcdr (1+ args-count) matched))) + (list nil nil)))) + ((or (not last-error) + (later-position error-position last-error-position)) + (setf last-error-position error-position + last-error error-descr))) + ;; if everything fails return the "best" error + finally (return (list last-error-position + (if *debug* + #'(lambda () + (format nil "~A, trying to match ~A" + (funcall (the function last-error)) + (rule-name first-expected))) + last-error))))) + (t + ;; if necessary load the next tokens + (when (null (cdr matched)) + (setf (cdr matched) (read-next-tokens tokenizer))) + (cond ((and (or (null expected) (eq first-expected :eof)) + (null (cdr matched))) + ;; This point is reached only once for each complete + ;; parsing. The expected tokens and the input + ;; tokens have been exhausted at the same time. + ;; Hence we succeeded the parsing. + (setf (cdr matched) (list :eof)) + (list nil nil)) + ((null expected) + ;; Garbage at end of parsing. This may mean that we + ;; have considered a production completed too soon. + (list (token-position (car matched)) + #'(lambda () + "garbage at end of parsing"))) + ((null (cdr matched)) + ;; EOF error + (list :eof + #'(lambda () + (format nil "end of input expecting ~S" expected)))) + (t ;; normal token + (let ((first-token (cadr matched))) + (if (match-token first-expected first-token) + (match (cdr expected) (cdr matched) #+debug depth) + ;; failed: we return the error + (list (token-position first-token) + #'(lambda () + (format nil "expected ~S but got ~S ~S" + first-expected (token-type first-token) + (token-value first-token))))))))))))) + (declare (inline match-token)) + (let ((result (list :head))) + (destructuring-bind (error-position error) + (match (list (find-rule start (grammar-rules grammar))) result #+debug 0) + (when error-position + (error "~A at ~A~%" (funcall (the function error)) error-position)) + (cadr result))))) + +(defgeneric terminals-in-grammar (grammar-or-hashtable) + (:documentation + "Find non constant terminal symbols in GRAMMAR.")) + +(defmethod terminals-in-grammar ((grammar hash-table)) + (loop + for rule being each hash-value of grammar + with terminals = '() + do (loop + for prod in (rule-productions rule) + do (loop + for tok in (prod-tokens prod) + when (symbolp tok) + do (pushnew tok terminals))) + finally (return terminals))) + +(defmethod terminals-in-grammar ((grammar grammar)) + (terminals-in-grammar (grammar-rules grammar))) + +(defun print-grammar-figures (grammar &optional (stream *standard-output*)) + (format stream "rules: ~A~%constant terminals: ~A~%variable terminals: ~S~%" + (hash-table-count (grammar-rules grammar)) + (hash-table-count (grammar-keywords grammar)) + (terminals-in-grammar (grammar-rules grammar)))) + + +(defun grammar-keyword-p (keyword grammar) + "Check if KEYWORD is part of this grammar." + (find-keyword keyword (grammar-keywords grammar))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *grammars* (make-hash-table)) + +(defun find-grammar (name) + (gethash name *grammars*)) + +(defun delete-grammar (name) + (remhash name *grammars*)) + +(defun add-grammar (name grammar) + (setf (gethash name *grammars*) grammar)) diff --git a/third_party/lisp/parse-float.nix b/third_party/lisp/parse-float.nix new file mode 100644 index 0000000000..e90824108e --- /dev/null +++ b/third_party/lisp/parse-float.nix @@ -0,0 +1,15 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.parse-float; +in depot.nix.buildLisp.library { + name = "parse-float"; + + deps = with depot.third_party.lisp; [ + alexandria + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "parse-float.lisp" + ]; +} diff --git a/third_party/lisp/parse-number.nix b/third_party/lisp/parse-number.nix new file mode 100644 index 0000000000..61b0b1fddb --- /dev/null +++ b/third_party/lisp/parse-number.nix @@ -0,0 +1,9 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.parse-number; +in depot.nix.buildLisp.library { + name = "parse-number"; + srcs = map (f: src + ("/" + f)) [ + "parse-number.lisp" + ]; +} diff --git a/third_party/lisp/parseq.nix b/third_party/lisp/parseq.nix new file mode 100644 index 0000000000..23c67c2d9c --- /dev/null +++ b/third_party/lisp/parseq.nix @@ -0,0 +1,13 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.parseq; +in depot.nix.buildLisp.library { + name = "parseq"; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "conditions.lisp" + "utils.lisp" + "defrule.lisp" + ]; +} diff --git a/third_party/lisp/physical-quantities.nix b/third_party/lisp/physical-quantities.nix new file mode 100644 index 0000000000..d594ff1a1c --- /dev/null +++ b/third_party/lisp/physical-quantities.nix @@ -0,0 +1,24 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.physical-quantities; +in depot.nix.buildLisp.library { + name = "physical-quantities"; + + deps = with depot.third_party.lisp; [ + parseq + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "utils.lisp" + "conditions.lisp" + "unit-factor.lisp" + "unit-database.lisp" + "units.lisp" + "quantity.lisp" + "numeric.lisp" + "parse-rules.lisp" + "read-macro.lisp" + "si-units.lisp" + ]; +} diff --git a/third_party/lisp/postmodern.nix b/third_party/lisp/postmodern.nix new file mode 100644 index 0000000000..25e0625c20 --- /dev/null +++ b/third_party/lisp/postmodern.nix @@ -0,0 +1,94 @@ +{ depot, pkgs, ... }: + +let + inherit (depot.nix.buildLisp) bundled; + src = with pkgs; srcOnly lispPackages.postmodern; + + cl-postgres = depot.nix.buildLisp.library { + name = "cl-postgres"; + deps = with depot.third_party.lisp; [ + md5 + split-sequence + ironclad + cl-base64 + uax-15 + usocket + ]; + + srcs = map (f: src + ("/cl-postgres/" + f)) [ + "package.lisp" + "features.lisp" + "config.lisp" + "oid.lisp" + "errors.lisp" + "data-types.lisp" + "sql-string.lisp" + "trivial-utf-8.lisp" + "strings-utf-8.lisp" + "communicate.lisp" + "messages.lisp" + "ieee-floats.lisp" + "interpret.lisp" + "saslprep.lisp" + "scram.lisp" + "protocol.lisp" + "public.lisp" + "bulk-copy.lisp" + ]; + }; + + s-sql = depot.nix.buildLisp.library { + name = "s-sql"; + deps = with depot.third_party.lisp; [ + cl-postgres + alexandria + ]; + + srcs = map (f: src + ("/s-sql/" + f)) [ + "package.lisp" + "config.lisp" + "s-sql.lisp" + ]; + }; + + postmodern = depot.nix.buildLisp.library { + name = "postmodern"; + + deps = with depot.third_party.lisp; [ + alexandria + cl-postgres + s-sql + global-vars + split-sequence + cl-unicode + closer-mop + bordeaux-threads + ]; + + srcs = [ + "${src}/postmodern.asd" + ] ++ (map (f: src + ("/postmodern/" + f)) [ + "package.lisp" + "config.lisp" + "connect.lisp" + "json-encoder.lisp" + "query.lisp" + "prepare.lisp" + "roles.lisp" + "util.lisp" + "transaction.lisp" + "namespace.lisp" + "execute-file.lisp" + "table.lisp" + "deftable.lisp" + ]); + + brokenOn = [ + "ecl" # TODO(sterni): https://gitlab.com/embeddable-common-lisp/ecl/-/issues/651 + ]; + }; + +in +postmodern // { + inherit s-sql cl-postgres; +} diff --git a/third_party/lisp/prove.nix b/third_party/lisp/prove.nix new file mode 100644 index 0000000000..af48149920 --- /dev/null +++ b/third_party/lisp/prove.nix @@ -0,0 +1,29 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.prove; +in depot.nix.buildLisp.library { + name = "prove"; + + deps = [ + depot.third_party.lisp.alexandria + depot.third_party.lisp.cl-ansi-text + depot.third_party.lisp.cl-colors + depot.third_party.lisp.cl-ppcre + (depot.nix.buildLisp.bundled "asdf") + ]; + + srcs = [ + "${src}/src/color.lisp" + "${src}/src/output.lisp" + "${src}/src/asdf.lisp" + "${src}/src/report.lisp" + "${src}/src/reporter.lisp" + "${src}/src/reporter/fiveam.lisp" + "${src}/src/reporter/list.lisp" + "${src}/src/reporter/dot.lisp" + "${src}/src/reporter/tap.lisp" + "${src}/src/suite.lisp" + "${src}/src/test.lisp" + "${src}/src/prove.lisp" + ]; +} diff --git a/third_party/lisp/puri.nix b/third_party/lisp/puri.nix new file mode 100644 index 0000000000..f7146ba93f --- /dev/null +++ b/third_party/lisp/puri.nix @@ -0,0 +1,10 @@ +# Portable URI library +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.puri; +in depot.nix.buildLisp.library { + name = "puri"; + srcs = [ + (src + "/src.lisp") + ]; +} diff --git a/third_party/lisp/qbase64/coreutils-base64.patch b/third_party/lisp/qbase64/coreutils-base64.patch new file mode 100644 index 0000000000..5a2f2a9f08 --- /dev/null +++ b/third_party/lisp/qbase64/coreutils-base64.patch @@ -0,0 +1,13 @@ +diff --git a/qbase64-test.lisp b/qbase64-test.lisp +index 310fdf3..b92abb5 100644 +--- a/qbase64-test.lisp ++++ b/qbase64-test.lisp +@@ -14,7 +14,7 @@ + (with-open-temporary-file (tmp :direction :output :element-type '(unsigned-byte 8)) + (write-sequence bytes tmp) + (force-output tmp) +- (let* ((encoded (uiop:run-program `("base64" "-b" ,(format nil "~A" linebreak) "-i" ,(namestring tmp)) :output (if (zerop linebreak) '(:string :stripped t) :string))) ++ (let* ((encoded (uiop:run-program `("base64" "-w" ,(format nil "~A" linebreak) ,(namestring tmp)) :output (if (zerop linebreak) '(:string :stripped t) :string) :error-output *error-output*)) + (length (length encoded))) + (cond ((and (> length 1) + (string= (subseq encoded (- length 2)) diff --git a/third_party/lisp/qbase64/default.nix b/third_party/lisp/qbase64/default.nix new file mode 100644 index 0000000000..40a93e04f0 --- /dev/null +++ b/third_party/lisp/qbase64/default.nix @@ -0,0 +1,57 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.applyPatches { + src = pkgs.fetchFromGitHub { + owner = "chaitanyagupta"; + repo = "qbase64"; + rev = "4ac193ed6b35a867ca453ed74acc128c9a077407"; + sha256 = "06daqqfdd51wkx0pyxgz7zq4ibzsqsgn3qs04jabx67gyybgnmjm"; + }; + + patches = [ + # qbase64 expects macOS base64 + ./coreutils-base64.patch + ]; + }; + + getSrcs = builtins.map (p: "${src}/${p}"); + +in + +depot.nix.buildLisp.library { + name = "qbase64"; + + srcs = getSrcs [ + "package.lisp" + "utils.lisp" + "stream-utils.lisp" + "qbase64.lisp" + ]; + + deps = [ + depot.third_party.lisp.trivial-gray-streams + depot.third_party.lisp.metabang-bind + ]; + + tests = { + name = "qbase64-tests"; + + srcs = getSrcs [ + "qbase64-test.lisp" + ]; + + deps = [ + { + sbcl = depot.nix.buildLisp.bundled "uiop"; + default = depot.nix.buildLisp.bundled "asdf"; + } + depot.third_party.lisp.fiveam + depot.third_party.lisp.cl-fad + ]; + + expression = '' + (fiveam:run! '(qbase64-test::encoder 'qbase64-test::decoder)) + ''; + }; +} diff --git a/third_party/lisp/quasiquote_2/README.md b/third_party/lisp/quasiquote_2/README.md new file mode 100644 index 0000000000..2d590a0564 --- /dev/null +++ b/third_party/lisp/quasiquote_2/README.md @@ -0,0 +1,258 @@ +quasiquote-2.0 +============== + +Why should it be hard to write macros that write other macros? +Well, it shouldn't! + +quasiquote-2.0 defines slightly different rules for quasiquotation, +that make writing macro-writing macros very smooth experience. + +NOTE: quasiquote-2.0 does horrible things to shared structure!!! +(it does a lot of COPY-TREE's, so shared-ness is destroyed). +So, it's indeed a tool to construct code (where it does not matter much if the +structure is shared or not) and not the data (or, at least, not the data with shared structure) + + +```lisp +(quasiquote-2.0:enable-quasiquote-2.0) + +(defmacro define-my-macro (name args &body body) + `(defmacro ,name ,args + `(sample-thing-to-expand-to + ,,@body))) ; note the difference from usual way + +(define-my-macro foo (x y) + ,x ; now here injections of quotation constructs work + ,y) + +(define-my-macro bar (&body body) + ,@body) ; splicing is also easy +``` + +The "injections" in macros FOO and BAR work as naively expected, as if I had written +```lisp +(defmacro foo (x y) + `(sample-thing-to-expand-to ,x ,y)) + +(defmacro bar (&body body) + `(sample-thing-to-expand-to ,@body)) + +(macroexpand-1 '(foo a b)) + + '(SAMPLE-THING-TO-EXPAND-TO A B) + +(macroexpand-1 '(bar a b c)) + + '(SAMPLE-THING-TO-EXPAND-TO A B C) +``` + + +So, how is this effect achieved? + + +DIG, INJECT and SPLICE +------------------------- + +The transformations of backquote occur at macroexpansion-time and not at read-time. +It is totally possible not to use any special reader syntax, but just +underlying macros directly! + +At the core is a macro DIG, which expands to the code that generates the +expression according to the rules, which are roughly these: + * each DIG increases "depth" by one (hence the name) + * each INJECT or SPLICE decreases "depth" by one + * if depth is 0, evaluation is turned on + * if depth if not zero (even if it's negative!) evaluation is off + * SPLICE splices the form, similarly to ordinary `,@`, INJECT simply injects, same as `,` + +```lisp +;; The example using macros, without special reader syntax + +(dig ; depth is 1 here + (a b + (dig ; depth is 2 here + ((inject c) ; this inject is not evaluated, because depth is nonzero + (inject (d ;depth becomes 1 here again + (inject e) ; and this inject is evaluated, because depth becomes zero + )) + (inject 2 f) ; this inject with level specification is evaluated, because it + ; decreases depth by 2 + )))) + + +;; the same example using ENABLE-QUASIQUOTE-2.0 syntax is written as +`(a b `(,c ,(d ,e) ,,f)) ; note double comma acts different than usually +``` + + +The ENABLE-QUASIQUOTE-2.0 macro just installs reader that reads +`FORM as (DIG FORM), ,FORM as (INJECT FORM) and ,@FORM as (SPLICE FORM). +You can just as well type DIG's, INJECT's and SPLICE's directly, +(in particular, when writing utility functions that generate macro-generating code) +or roll your own convenient reader syntax (pull requests are welcome). + +So, these two lines (with ENABLE-QUASIQUOTE-2.0) read the same +```lisp +`(a (,b `,,c) d) + +(dig (a ((inject b) (dig (inject 2 c))) d)) +``` + +You may notice the (INJECT 2 ...) form appearing, which is described below. + + +At "level 1", i.e. when only \` , and ,@ are used, and not, say \`\` ,, ,', ,,@ ,',@ +this behaves exactly as usual quasiquotation. + + +The optional N argument +-------------- + +All quasiquote-2.0 operators accept optional "depth" argument, +which goes before the form for human readability. + +Namely, (DIG N FORM) increases depth by N instead of one and +(INJECT N FORM) decreases depth by N instead of one. + +```lisp +(DIG 2 (INJECT 2 A)) + +; gives the same result as + +(DIG (INJECT A)) +``` + + +In fact, with ENABLE-QUASIQUOTE-2.0, say, ,,,,,FORM (5 quotes) reads as (INJECT 5 FORM) +and ,,,,,@FORM as (SPLICE 5 FORM) + + +More examples +------------- + +For fairly complicated example, which uses ,,,@ and OINJECT (see below), + see DEFINE-BINOP-DEFINER macro +in CG-LLVM (https://github.com/mabragor/cg-llvm/src/basics.lisp), +desire to write which was the initial impulse for this project. + + +For macro, that is not a macro-writing macro, yet benefits from +ability to inject using `,` and `,@`, consider JOINING-WITH-COMMA-SPACE macro +(also from CG-LLVM) + +```lisp +(defmacro joining-with-comma-space (&body body) + ;; joinl just joins strings in the list with specified string + `(joinl ", " (mapcar #'emit-text-repr + (remove-if-not #'identity `(,,@body))))) + +;; the macro can be then used uniformly over strings and lists of strings +(defun foo (x y &rest z) + (joining-with-comma-space ,x ,y ,@z)) + +(foo "a" "b" "c" "d") + ;; produces + "a, b, c, d" +``` + + +ODIG and OINJECT and OSPLICE +---------------------------- + +Sometimes you don't want DIG's macroexpansion to look further into the structure of +some INJECT or SPLICE or DIG in its subform, +if the depth does not match. In these cases you need "opaque" versions of +DIG, INJECT and SPLICE, named, respectively, ODIG, OINJECT and OSPLICE. + +```lisp +;; here injection of B would occur +(defun foo (b) + (dig (dig (inject (a (inject b)))))) + +;; and here not, because macroexpansion does not look into OINJECT form +(defun bar (b) + (dig (dig (oinject (a (inject b)))))) + +(foo 1) + + '(DIG (INJECT (A 1))) + +(bar 1) + + '(DIG (OINJECT (A (INJECT B)))) +``` + +MACRO-INJECT and MACRO-SPLICE +----------------------------- + +Sometimes you just want to abstract-out some common injection patterns... +That is, you want macros, that expand into common injection patterns. +However, you want this only sometimes, and only in special circumstances. +So it won't do, if INJECT and SPLICE just expanded something, whenever it +turned out to be macro. For that, use MACRO-INJECT and MACRO-SPLICE. + +```lisp +;; with quasiquote-2.0 syntax turned on +(defmacro inject-n-times (form n) + (make-list n :initial-element `(inject ,form))) + +(let (x 0) + `(dig (a (macro-inject (inject-n-times (incf x) 3))))) +;; yields +'(a (1 2 3)) + +;;and same with MACRO-SPLICE +(let (x 0) + `(dig (a (macro-splice (inject-n-times (incf x) 3))))) +;; yields +'(a 1 2 3) +``` + +OMACRO-INJECT and OMACRO-SPLICE are, as usual, opaque variants of MACRO-INJECT and MACRO-SPLICE. + +Both MACRO-INJECT and MACRO-SPLICE expand their subform exactly once (using MACROEXPAND-1), +before plugging it into list. +If you want to expand as much as it's possible, use MACRO-INJECT-ALL and MACRO-SPLICE-ALL, +which expand using MACROEXPAND before injecting/splicing, respectively. +That implies, that while subform of MACRO-INJECT and MACRO-SPLICE is checked to be +macro-form, the subform of MACRO-INJECT-ALL is not. + + +Terse syntax of the ENABLE-QUASIQUOTE-2.0 +----------------------------------------- + +Of course, typing all those MACRO-INJECT-ALL, or OMACRO-SPLICE-ALL or whatever explicitly +every time you want this special things is kind of clumsy. For that, default reader +of quasiquote-2.0 provides extended syntax + +```lisp +',,,,!oma@x + +;; reads as +'(OMACRO-SPLICE-ALL 4 X) +``` + +That is, the regexp of the syntax is +[,]+![o][m][a][@]<whatever> + +As usual, number of commas determine the anti-depth of the injector, exclamation mark +turns on the syntax, if `o` is present, opaque version of injector will be used, +if `m` is present, macro-expanding version of injector will be used and if +`a` is present, macro-all version of injector will be used. + +Note: it's possible to write ,!ax, which will read as (INJECT-ALL X), but +this will not correspond to the actual macro name. + +Note: it was necessary to introduce special escape-char for extended syntax, +since usual idioms like `,args` would otherwise be completely screwed. + + +TODO +---- + +* WITH-QUASIQUOTE-2.0 read-macro-token for local enabling of ` and , overloading +* wrappers for convenient definition of custom overloading schemes +* some syntax for opaque operations + +P.S. Name "quasiquote-2.0" comes from "patronus 2.0" spell from www.hpmor.com + and has nothing to do with being "the 2.0" version of quasiquote. \ No newline at end of file diff --git a/third_party/lisp/quasiquote_2/default.nix b/third_party/lisp/quasiquote_2/default.nix new file mode 100644 index 0000000000..521c384787 --- /dev/null +++ b/third_party/lisp/quasiquote_2/default.nix @@ -0,0 +1,17 @@ +# Quasiquote more suitable for macros that define other macros +{ depot, ... }: + +depot.nix.buildLisp.library { + name = "quasiquote-2.0"; + + deps = [ + depot.third_party.lisp.iterate + ]; + + srcs = [ + ./package.lisp + ./quasiquote-2.0.lisp + ./macros.lisp + ./readers.lisp + ]; +} diff --git a/third_party/lisp/quasiquote_2/macros.lisp b/third_party/lisp/quasiquote_2/macros.lisp new file mode 100644 index 0000000000..6ebeb47d08 --- /dev/null +++ b/third_party/lisp/quasiquote_2/macros.lisp @@ -0,0 +1,15 @@ + +(in-package #:quasiquote-2.0) + +(defmacro define-dig-like-macro (name) + `(defmacro ,name (n-or-form &optional (form nil form-p) &environment env) + (if (not form-p) + `(,',name 1 ,n-or-form) + (let ((*env* env)) + (transform-dig-form `(,',name ,n-or-form ,form)))))) + + +(define-dig-like-macro dig) +(define-dig-like-macro odig) + + diff --git a/third_party/lisp/quasiquote_2/package.lisp b/third_party/lisp/quasiquote_2/package.lisp new file mode 100644 index 0000000000..9b140ef84c --- /dev/null +++ b/third_party/lisp/quasiquote_2/package.lisp @@ -0,0 +1,11 @@ +;;;; package.lisp + +(defpackage #:quasiquote-2.0 + (:use #:cl #:iterate) + (:export #:%codewalk-dig-form #:transform-dig-form + #:dig #:inject #:splice #:odig #:oinject #:osplice + #:macro-inject #:omacro-inject #:macro-splice #:omacro-splice + #:macro-inject-all #:omacro-inject-all #:macro-splice-all #:omacro-splice-all + #:enable-quasiquote-2.0 #:disable-quasiquote-2.0)) + + diff --git a/third_party/lisp/quasiquote_2/quasiquote-2.0.asd b/third_party/lisp/quasiquote_2/quasiquote-2.0.asd new file mode 100644 index 0000000000..3acfd32b80 --- /dev/null +++ b/third_party/lisp/quasiquote_2/quasiquote-2.0.asd @@ -0,0 +1,30 @@ +;;;; quasiquote-2.0.asd + +(defpackage :quasiquote-2.0-system + (:use :cl :asdf)) + +(in-package quasiquote-2.0-system) + +(asdf:defsystem #:quasiquote-2.0 + :serial t + :description "Writing macros that write macros. Effortless." + :author "Alexandr Popolitov <popolit@gmail.com>" + :license "MIT" + :version "0.3" + :depends-on (#:iterate) + :components ((:file "package") + (:file "quasiquote-2.0") + (:file "macros") + (:file "readers"))) + +(defsystem :quasiquote-2.0-tests + :description "Tests for QUASIQUOTE-2.0" + :licence "MIT" + :depends-on (:quasiquote-2.0 :fiveam) + :components ((:file "tests") + (:file "tests-macro") + )) + +(defmethod perform ((op test-op) (sys (eql (find-system :quasiquote-2.0)))) + (load-system :quasiquote-2.0) + (funcall (intern "RUN-TESTS" :quasiquote-2.0))) diff --git a/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp b/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp new file mode 100644 index 0000000000..10043fe0ec --- /dev/null +++ b/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp @@ -0,0 +1,340 @@ +;;;; quasiquote-2.0.lisp + +(in-package #:quasiquote-2.0) + +(defparameter *env* nil) + +(defmacro nonsense-error (str) + `(error ,(concatenate 'string + str + " appears as a bare, non DIG-enclosed form. " + "For now I don't know how to make sense of this."))) + +(defmacro define-nonsense-when-bare (name) + `(defmacro ,name (n-or-form &optional form) + (declare (ignore n-or-form form)) + (nonsense-error ,(string name)))) + +(define-nonsense-when-bare inject) +(define-nonsense-when-bare oinject) +(define-nonsense-when-bare splice) +(define-nonsense-when-bare osplice) +(define-nonsense-when-bare macro-inject) + +(defparameter *depth* 0) + + +(defparameter *injectors* nil) + +(defparameter *void-elt* nil) +(defparameter *void-filter-needed* nil) + +;; (defmacro with-injector-parsed (form) +;; `(let ((kwd (intern (string + +(defun reset-injectors () + (setf *injectors* nil)) + +(defparameter *known-injectors* '(inject splice oinject osplice + macro-inject omacro-inject + macro-splice omacro-splice + macro-inject-all omacro-inject-all + macro-splice-all omacro-splice-all)) + +(defun injector-form-p (form) + (and (consp form) + (find (car form) *known-injectors* :test #'eq))) + +(defun injector-level (form) + (if (equal 2 (length form)) + 1 + (cadr form))) + +(defun injector-subform (form) + (if (equal 2 (length form)) + (values (cdr form) '(cdr)) + (values (cddr form) '(cddr)))) + +(defparameter *opaque-injectors* '(odig oinject osplice omacro-inject)) + +(defun transparent-p (form) + (not (find (car form) *opaque-injectors* :test #'eq))) + +(defun look-into-injector (form path) + (let ((*depth* (- *depth* (injector-level form)))) + (multiple-value-bind (subform subpath) (injector-subform form) + (search-all-active-sites subform (append subpath path) nil)))) + +(defparameter *known-diggers* '(dig odig)) + +(defun dig-form-p (form) + (and (consp form) + (find (car form) *known-diggers* :test #'eq))) + +(defun look-into-dig (form path) + (let ((*depth* (+ *depth* (injector-level form)))) + (multiple-value-bind (subform subpath) (injector-subform form) + (search-all-active-sites subform (append subpath path) nil)))) + +(defun handle-macro-1 (form) + (if (atom form) + (error "Sorry, symbol-macros are not implemented for now") + (let ((fun (macro-function (car form) *env*))) + (if (not fun) + (error "The subform of MACRO-1 injector is supposed to be macro, perhaps, something went wrong...")) + (macroexpand-1 form *env*)))) + +(defun handle-macro-all (form) + (if (atom form) + (error "Sorry, symbol-macros are not implemented for now") + (macroexpand form *env*))) + + +(defparameter *macro-handlers* `((macro-inject . ,#'handle-macro-1) + (omacro-inject . ,#'handle-macro-1) + (macro-splice . ,#'handle-macro-1) + (omacro-splice . ,#'handle-macro-1) + (macro-inject-all . ,#'handle-macro-all) + (omacro-inject-all . ,#'handle-macro-all) + (macro-splice-all . ,#'handle-macro-all) + (omacro-splice-all . ,#'handle-macro-all))) + +(defun get-macro-handler (sym) + (or (cdr (assoc sym *macro-handlers*)) + (error "Don't know how to handle this macro injector: ~a" sym))) + + + +(defun macroexpand-macroinjector (place) + (if (not (splicing-injector (car place))) + (progn (setf (car place) (funcall (get-macro-handler (caar place)) + (car (injector-subform (car place))))) + nil) + (let ((new-forms (funcall (get-macro-handler (caar place)) + (car (injector-subform (car place)))))) + (cond ((not new-forms) + (setf *void-filter-needed* t + (car place) *void-elt*)) + ((atom new-forms) (error "We need to splice the macroexpansion, but got atom: ~a" new-forms)) + (t (setf (car place) (car new-forms)) + (let ((tail (cdr place))) + (setf (cdr place) (cdr new-forms) + (cdr (last new-forms)) tail)))) + t))) + + +(defun search-all-active-sites (form path toplevel-p) + ;; (format t "SEARCH-ALL-ACTIVE-SITES: got form ~a~%" form) + (if (not form) + nil + (if toplevel-p + (cond ((atom (car form)) :just-quote-it!) + ((injector-form-p (car form)) (if (equal *depth* (injector-level (car form))) + :just-form-it! + (if (transparent-p (car form)) + (look-into-injector (car form) (cons 'car path))))) + ((dig-form-p (car form)) + ;; (format t "Got dig form ~a~%" form) + (if (transparent-p (car form)) + (look-into-dig (car form) (cons 'car path)))) + (t (search-all-active-sites (car form) (cons 'car path) nil) + (search-all-active-sites (cdr form) (cons 'cdr path) nil))) + (when (consp form) + (cond ((dig-form-p (car form)) + ;; (format t "Got dig form ~a~%" form) + (if (transparent-p (car form)) + (look-into-dig (car form) (cons 'car path)))) + ((injector-form-p (car form)) + ;; (format t "Got injector form ~a ~a ~a~%" form *depth* (injector-level (car form))) + (if (equal *depth* (injector-level (car form))) + (if (macro-injector-p (car form)) + (progn (macroexpand-macroinjector form) + (return-from search-all-active-sites + (search-all-active-sites form path nil))) + (progn (push (cons form (cons 'car path)) *injectors*) + nil)) + (if (transparent-p (car form)) + (look-into-injector (car form) (cons 'car path))))) + (t (search-all-active-sites (car form) (cons 'car path) nil))) + (search-all-active-sites (cdr form) (cons 'cdr path) nil))))) + + + +(defun codewalk-dig-form (form) + (reset-injectors) + (let ((it (search-all-active-sites form nil t))) + (values (nreverse *injectors*) it))) + +(defun %codewalk-dig-form (form) + (if (not (dig-form-p form)) + (error "Supposed to be called on dig form") + (let ((*depth* (+ (injector-level form) *depth*))) + (codewalk-dig-form (injector-subform form))))) + +(defun path->setfable (path var) + (let ((res var)) + ;; First element is artifact of extra CAR-ing + (dolist (spec (cdr (reverse path))) + (setf res (list spec res))) + res)) + +(defun tree->cons-code (tree) + (if (atom tree) + `(quote ,tree) + `(cons ,(tree->cons-code (car tree)) + ,(tree->cons-code (cdr tree))))) + +(defparameter *known-splicers* '(splice osplice + macro-splice omacro-splice + macro-splice-all omacro-splice-all)) + +(defun splicing-injector (form) + (and (consp form) + (find (car form) *known-splicers* :test #'eq))) + +(defparameter *known-macro-injectors* '(macro-inject omacro-inject + macro-splice omacro-splice + macro-inject-all omacro-inject-all + macro-splice-all omacro-splice-all + )) + +(defun macro-injector-p (form) + (and (consp form) + (find (car form) *known-macro-injectors* :test #'eq))) + +(defun filter-out-voids (lst void-sym) + (let (caars cadrs cdars cddrs) + ;; search for all occurences of VOID + (labels ((rec (x) + (if (consp x) + (progn (cond ((consp (car x)) + (cond ((eq void-sym (caar x)) (push x caars)) + ((eq void-sym (cdar x)) (push x cdars)))) + ((consp (cdr x)) + (cond ((eq void-sym (cadr x)) (push x cadrs)) + ((eq void-sym (cddr x)) (push x cddrs))))) + (rec (car x)) + (rec (cdr x)))))) + (rec lst)) + (if (or cdars cddrs) + (error "Void sym found on CDR position, which should not have happened")) + ;; destructively transform LST + (dolist (elt caars) + (setf (car elt) (cdar elt))) + (dolist (elt cadrs) + (setf (cdr elt) (cddr elt))) + ;; check that we indeed filtered-out all VOIDs + (labels ((rec (x) + (if (not (atom x)) + (progn (rec (car x)) + (rec (cdr x))) + (if (eq void-sym x) + (error "Not all VOIDs were filtered"))))) + (rec lst)) + lst)) + +(defun transform-dig-form (form) + (let ((the-form (copy-tree form))) + (let ((*void-filter-needed* nil) + (*void-elt* (gensym "VOID"))) + (multiple-value-bind (site-paths cmd) (%codewalk-dig-form the-form) + (cond ((eq cmd :just-quote-it!) + `(quote ,(car (injector-subform the-form)))) + ((eq cmd :just-form-it!) + (car (injector-subform (car (injector-subform the-form))))) + (t (let ((cons-code (if (not site-paths) + (tree->cons-code (car (injector-subform the-form))) + (really-transform-dig-form the-form site-paths)))) + (if (not *void-filter-needed*) + cons-code + `(filter-out-voids ,cons-code ',*void-elt*))))))))) + +(defmacro make-list-form (o!-n form) + (let ((g!-n (gensym "N")) + (g!-i (gensym "I")) + (g!-res (gensym "RES"))) + `(let ((,g!-n ,o!-n) + (,g!-res nil)) + (dotimes (,g!-i ,g!-n) + (push ,form ,g!-res)) + (nreverse ,g!-res)))) + +(defun mk-splicing-injector-let (x) + `(let ((it ,(car (injector-subform x)))) + (assert (listp it)) + (copy-list it))) + + + +(defun mk-splicing-injector-setf (path g!-list g!-splicee) + (assert (eq 'car (car path))) + (let ((g!-rest (gensym "REST"))) + `(let ((,g!-rest ,(path->setfable (cons 'cdr (cdr path)) g!-list))) + (assert (or (not ,g!-rest) (consp ,g!-rest))) + (if (not ,g!-splicee) + (setf ,(path->setfable (cdr path) g!-list) + ,g!-rest) + (progn (setf ,(path->setfable (cdr path) g!-list) ,g!-splicee) + (setf (cdr (last ,g!-splicee)) ,g!-rest)))))) + + +(defun really-transform-dig-form (the-form site-paths) + (let ((gensyms (make-list-form (length site-paths) (gensym "INJECTEE")))) + (let ((g!-list (gensym "LIST"))) + (let ((lets nil) + (splicing-setfs nil) + (setfs nil)) + (do ((site-path site-paths (cdr site-path)) + (gensym gensyms (cdr gensym))) + ((not site-path)) + (destructuring-bind (site . path) (car site-path) + (push `(,(car gensym) ,(if (not (splicing-injector (car site))) + (car (injector-subform (car site))) + (mk-splicing-injector-let (car site)))) + lets) + (if (not (splicing-injector (car site))) + (push `(setf ,(path->setfable path g!-list) ,(car gensym)) setfs) + (push (mk-splicing-injector-setf path g!-list (car gensym)) splicing-setfs)) + (setf (car site) nil))) + `(let ,(nreverse lets) + (let ((,g!-list ,(tree->cons-code (car (injector-subform the-form))))) + ,@(nreverse setfs) + ;; we apply splicing setf in reverse order for them not to bork the paths of each other + ,@splicing-setfs + ,g!-list)))))) + + +;; There are few types of recursive injection that may happen: +;; * compile-time injection: +;; (dig (inject (dig (inject a)))) -- this type will be handled automatically by subsequent macroexpansions +;; * run-time injection: +;; (dig (dig (inject 2 a))) +;; and A is '(dig (inject 3 'foo)) -- this one we guard against ? (probably, first we just ignore it +;; -- do not warn about it, and then it wont really happen. +;; * macroexpanded compile-time injection: +;; (dig (inject (my-macro a b c))), +;; where MY-MACRO expands into, say (splice (list 'a 'b 'c)) +;; This is *not* handled automatically, and therefore we must do it by hand. + + +;; OK, now how to implement splicing ? +;; (dig (a (splice (list b c)) d)) +;; should transform into code that yields +;; (a b c d) +;; what this code is? +;; (let ((#:a (copy-list (list b c)))) +;; (let ((#:res (cons 'a nil 'd))) +;; ;; all non-splicing injects go here, as they do not spoil the path-structure +;; (setf (cdr #:res) #:a) +;; (setf (cdr (last #:a)) (cdr (cdr #:res))) +;; #:res))) + + +;; How this macroexpansion should work in general? +;; * We go over the cons-tree, keeping track of the depth level, which is +;; controlled by DIG's +;; * Once we find the INJECT with matching level, we remember the place, where +;; this happens +;; * We have two special cases: +;; * cons-tree is an atom +;; * cons-tree is just a single INJECT diff --git a/third_party/lisp/quasiquote_2/readers.lisp b/third_party/lisp/quasiquote_2/readers.lisp new file mode 100644 index 0000000000..7c4c5a30c9 --- /dev/null +++ b/third_party/lisp/quasiquote_2/readers.lisp @@ -0,0 +1,77 @@ + + +(in-package #:quasiquote-2.0) + +(defun read-n-chars (stream char) + (let (new-char + (n 0)) + (loop + (setf new-char (read-char stream nil :eof t)) + (if (not (char= new-char char)) + (progn (unread-char new-char stream) + (return n)) + (incf n))))) + +(defmacro define-dig-reader (name symbol) + `(defun ,name (stream char) + (let ((depth (1+ (read-n-chars stream char)))) + (if (equal 1 depth) + (list ',symbol (read stream t nil t)) + (list ',symbol + depth + (read stream t nil t)))))) + +(define-dig-reader dig-reader dig) +(define-dig-reader odig-reader odig) + +(defun expect-char (char stream) + (let ((new-char (read-char stream t nil t))) + (if (char= char new-char) + t + (unread-char new-char stream)))) + +(defun guess-injector-name (opaque-p macro-p all-p splicing-p) + (intern (concatenate 'string + (if opaque-p "O" "") + (if macro-p "MACRO-" "") + (if splicing-p "SPLICE" "INJECT") + (if all-p "-ALL" "")) + "QUASIQUOTE-2.0")) + +(defun inject-reader (stream char) + (let ((anti-depth (1+ (read-n-chars stream char))) + (extended-syntax (expect-char #\! stream))) + (let ((injector-name (if (not extended-syntax) + (guess-injector-name nil nil nil (expect-char #\@ stream)) + (guess-injector-name (expect-char #\o stream) + (expect-char #\m stream) + (expect-char #\a stream) + (expect-char #\@ stream))))) + `(,injector-name ,@(if (not (equal 1 anti-depth)) `(,anti-depth)) + ,(read stream t nil t))))) + + + +(defvar *previous-readtables* nil) + +(defun %enable-quasiquote-2.0 () + (push *readtable* + *previous-readtables*) + (setq *readtable* (copy-readtable)) + (set-macro-character #\` #'dig-reader) + (set-macro-character #\, #'inject-reader) + (values)) + +(defun %disable-quasiquote-2.0 () + (if *previous-readtables* + (setf *readtable* (pop *previous-readtables*)) + (setf *readtable* (copy-readtable nil))) + (values)) + +(defmacro enable-quasiquote-2.0 () + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%enable-quasiquote-2.0))) +(defmacro disable-quasiquote-2.0 () + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%disable-quasiquote-2.0))) + diff --git a/third_party/lisp/quasiquote_2/tests-macro.lisp b/third_party/lisp/quasiquote_2/tests-macro.lisp new file mode 100644 index 0000000000..df6c43e21d --- /dev/null +++ b/third_party/lisp/quasiquote_2/tests-macro.lisp @@ -0,0 +1,21 @@ + +(in-package #:quasiquote-2.0-tests) + +(in-suite quasiquote-2.0) + +(enable-quasiquote-2.0) + +(defmacro define-sample-macro (name args &body body) + `(defmacro ,name ,args + `(sample-thing-to-macroexpand-to + ,,@body))) + +(define-sample-macro sample-macro-1 (x y) + ,x ,y) + +(define-sample-macro sample-macro-2 (&body body) + ,@body) + +(test macro-defined-macroexpansions + (is (equal '(sample-thing-to-macroexpand-to a b) (macroexpand-1 '(sample-macro-1 a b)))) + (is (equal '(sample-thing-to-macroexpand-to a b c) (macroexpand-1 '(sample-macro-2 a b c))))) \ No newline at end of file diff --git a/third_party/lisp/quasiquote_2/tests.lisp b/third_party/lisp/quasiquote_2/tests.lisp new file mode 100644 index 0000000000..6c8ab08cc1 --- /dev/null +++ b/third_party/lisp/quasiquote_2/tests.lisp @@ -0,0 +1,143 @@ +(in-package :cl-user) + +(defpackage :quasiquote-2.0-tests + (:use :cl :quasiquote-2.0 :fiveam) + (:export #:run-tests)) + +(in-package :quasiquote-2.0-tests) + +(def-suite quasiquote-2.0) +(in-suite quasiquote-2.0) + +(defun run-tests () + (let ((results (run 'quasiquote-2.0))) + (fiveam:explain! results) + (unless (fiveam:results-status results) + (error "Tests failed.")))) + +(test basic + (is (equal '(nil :just-quote-it!) (multiple-value-list (%codewalk-dig-form '(dig nil))))) + (is (equal '(nil :just-form-it!) (multiple-value-list (%codewalk-dig-form '(dig (inject a)))))) + (is (equal '(nil :just-form-it!) (multiple-value-list (%codewalk-dig-form '(dig 2 (inject 2 a)))))) + (is (equal '(((((inject b) c (inject d)) car cdr car) (((inject d)) car cdr cdr cdr car)) nil) + (multiple-value-list (%codewalk-dig-form '(dig (a (inject b) c (inject d))))))) + (is (equal '(nil nil) + (multiple-value-list (%codewalk-dig-form '(dig (dig (a (inject b) c (inject d)))))))) + (is (equal '(((((inject 2 d)) car cdr cdr cdr car cdr car)) nil) + (multiple-value-list (%codewalk-dig-form '(dig (dig (a (inject b) c (inject 2 d))))))))) + +(test transform + (is (equal '(quote a) (transform-dig-form '(dig a)))) + (is (equal '(quote a) (transform-dig-form '(dig 2 a)))) + (is (equal 'a (transform-dig-form '(dig (inject a))))) + (is (equal 'a (transform-dig-form '(dig 2 (inject 2 a)))))) + +(defun foo (b d) + (dig (a (inject b) c (inject d)))) + +(defun foo1-transparent (x) + (declare (ignorable x)) + (dig (dig (a (inject (b (inject x) c)))))) + +(defun foo1-opaque (x) + (declare (ignorable x)) + (dig (dig (a (oinject (b (inject x) c)))))) + +(defun foo-recursive (x y) + (dig (a (inject (list x (dig (c (inject y)))))))) + + +(test foos + (is (equal '(a 1 c 2) (foo 1 2))) + (is (equal '(a 100 c 200) (foo 100 200)))) + +(test opaque-vs-transparent + (is (equal '(quote a) (transform-dig-form '(odig a)))) + (is (equal '(quote a) (transform-dig-form '(odig 2 a)))) + (is (equal 'a (transform-dig-form '(odig (inject a))))) + (is (equal 'a (transform-dig-form '(odig 2 (inject 2 a))))) + (is (equal '(odig (inject 2 a)) (eval (transform-dig-form '(dig (odig (inject 2 a))))))) + (is (equal '(dig (a (inject (b 3 c)))) (foo1-transparent 3))) + (is (equal '(dig (a (oinject (b (inject x) c)))) (foo1-opaque 3)))) + +(test recursive-compile-time + (is (equal '(a (1 (c 2))) (foo-recursive 1 2)))) + + +(test splicing + (is (equal '(a b c d) (eval (transform-dig-form '(dig (a (splice '(b c)) d)))))) + (is (equal '(b c d) (eval (transform-dig-form '(dig ((splice '(b c)) d)))))) + (is (equal '(a b c) (eval (transform-dig-form '(dig (a (splice '(b c)))))))) + (is (equal '(a b) (eval (transform-dig-form '(dig (a (splice nil) b)))))) + (is (equal '(b) (eval (transform-dig-form '(dig ((splice nil) b)))))) + (is (equal '(a) (eval (transform-dig-form '(dig (a (splice nil))))))) + (is (equal '() (eval (transform-dig-form '(dig ((splice nil))))))) + (is (equal '(a b) (eval (transform-dig-form '(dig ((splice '(a b))))))))) + + +(test are-they-macro + (is (not (equal '(dig (a b)) (macroexpand-1 '(dig (a b)))))) + (is (not (equal '(odig (a b)) (macroexpand-1 '(odig (a b))))))) + + +(defmacro triple-var (x) + `((inject ,x) (inject ,x) (inject ,x))) + +(test correct-order-of-effects + (is (equal '(a 1 2 3) (let ((x 0)) + (dig (a (inject (incf x)) (inject (incf x)) (inject (incf x))))))) + (is (equal '(a (((1))) 2) + (let ((x 0)) + (dig (a ((((inject (incf x))))) (inject (incf x)))))))) + +(test macro-injects + (is (equal '(a (3 3 3)) (let ((x 3)) + (dig (a (macro-inject (triple-var x))))))) + (is (equal '(a (1 2 3)) (let ((x 0)) + (dig (a (macro-inject (triple-var (incf x)))))))) + (macrolet ((frob (form n) + (mapcar (lambda (x) + `(inject ,x)) + (make-list n :initial-element form))) + (frob1 (form) + `(frob ,form 4))) + (is (equal '(a (1 2 3 4 5)) + (let ((x 0)) + (dig (a (macro-inject (frob (incf x) 5))))))) + (is (equal '(a 1 2 3 4 5) + (let ((x 0)) + (dig (a (macro-splice (frob (incf x) 5))))))) + (is (equal '(a) + (let ((x 0)) + (declare (ignorable x)) + (dig (a (macro-splice (frob (incf x) 0))))))) + (is (equal '(a frob (incf x) 4) + (let ((x 0)) + (declare (ignorable x)) + (dig (a (macro-splice (frob1 (incf x)))))))) + (is (equal '(a 1 2 3 4) + (let ((x 0)) + (dig (a (macro-splice-all (frob1 (incf x)))))))))) + + +(quasiquote-2.0:enable-quasiquote-2.0) + +(test reader + (is (equal '(inject x) ',x)) + (is (equal '(inject 3 x) ',,,x)) + (is (equal '(splice x) ',@x)) + (is (equal '(splice 3 x) ',,,@x)) + (is (equal '(omacro-splice-all 4 x) ',,,,!oma@x)) + (is (equal '(inject 4 oma@x) ',,,,oma@x))) + +(test macro-splices + (macrolet ((splicer (x) + ``(splice ,x))) + (is (equal '(a 1 2 3) (let ((x '(1 2 3))) + `(a ,!m(splicer x))))))) + +(test repeated-splices + (is (equal '(a) `(a ,@nil ,@nil ,@nil ,@nil))) + (is (equal '(a b c d e f g) `(a ,@(list 'b 'c) ,@(list 'd 'e) ,@nil ,@(list 'f 'g))))) + + \ No newline at end of file diff --git a/third_party/lisp/rfc2388.nix b/third_party/lisp/rfc2388.nix new file mode 100644 index 0000000000..b82a490c9d --- /dev/null +++ b/third_party/lisp/rfc2388.nix @@ -0,0 +1,12 @@ +# Implementation of RFC2388 (multipart/form-data) +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.rfc2388; +in depot.nix.buildLisp.library { + name = "rfc2388"; + + srcs = map (f: src + ("/" + f)) [ + "packages.lisp" + "rfc2388.lisp" + ]; +} diff --git a/third_party/lisp/routes.nix b/third_party/lisp/routes.nix new file mode 100644 index 0000000000..fc7d4e3067 --- /dev/null +++ b/third_party/lisp/routes.nix @@ -0,0 +1,39 @@ +{ depot, pkgs, ... }: + +let + + src = pkgs.applyPatches { + name = "routes-source"; + src = pkgs.fetchFromGitHub { + owner = "archimag"; + repo = "cl-routes"; + rev = "1b79e85aa653e1ec87e21ca745abe51547866fa9"; + sha256 = "1zpk3cp2v8hm50ppjl10yxr437vv4552r8hylvizglzrq2ibsbr1"; + }; + + patches = [ + (pkgs.fetchpatch { + name = "fix-build-with-ccl.patch"; + url = "https://github.com/archimag/cl-routes/commit/2296cdc316ef8e34310f2718b5d35a30040deee0.patch"; + sha256 = "007c19kmymalam3v6l6y2qzch8xs3xnphrcclk1jrpggvigcmhax"; + }) + ]; + }; + +in +depot.nix.buildLisp.library { + name = "routes"; + + deps = with depot.third_party.lisp; [ + puri + iterate + split-sequence + ]; + + srcs = map (f: src + ("/src/" + f)) [ + "package.lisp" + "uri-template.lisp" + "route.lisp" + "mapper.lisp" + ]; +} diff --git a/third_party/lisp/s-sysdeps.nix b/third_party/lisp/s-sysdeps.nix new file mode 100644 index 0000000000..9c4da4a02b --- /dev/null +++ b/third_party/lisp/s-sysdeps.nix @@ -0,0 +1,18 @@ +# A Common Lisp abstraction layer over platform dependent functionality. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.s-sysdeps; +in depot.nix.buildLisp.library { + name = "s-sysdeps"; + + srcs = [ + "${src}/src/package.lisp" + "${src}/src/sysdeps.lisp" + ]; + + deps = with depot.third_party.lisp; [ + bordeaux-threads + usocket + usocket-server + ]; +} diff --git a/third_party/lisp/s-xml/0001-fix-definition-order-in-xml.lisp.patch b/third_party/lisp/s-xml/0001-fix-definition-order-in-xml.lisp.patch new file mode 100644 index 0000000000..9e5838c3c5 --- /dev/null +++ b/third_party/lisp/s-xml/0001-fix-definition-order-in-xml.lisp.patch @@ -0,0 +1,26 @@ +From 789dc38399f4039b114de28384c149721d66b030 Mon Sep 17 00:00:00 2001 +From: Vincent Ambo <mail@tazj.in> +Date: Thu, 16 Dec 2021 00:48:04 +0300 +Subject: [PATCH] fix definition order in xml.lisp + +--- + src/xml.lisp | 3 +++ + 1 file changed, 3 insertions(+) + +diff --git a/src/xml.lisp b/src/xml.lisp +index 39c9b63..3232491 100644 +--- a/src/xml.lisp ++++ b/src/xml.lisp +@@ -19,6 +19,9 @@ + + ;;; error reporting + ++(defvar *ignore-namespaces* nil ++ "When t, namespaces are ignored like in the old version of S-XML") ++ + (define-condition xml-parser-error (error) + ((message :initarg :message :reader xml-parser-error-message) + (args :initarg :args :reader xml-parser-error-args) +-- +2.34.0 + diff --git a/third_party/lisp/s-xml/default.nix b/third_party/lisp/s-xml/default.nix new file mode 100644 index 0000000000..486e1c1ac8 --- /dev/null +++ b/third_party/lisp/s-xml/default.nix @@ -0,0 +1,25 @@ +# XML serialiser for Common Lisp. +{ depot, pkgs, ... }: + +let + src = pkgs.applyPatches { + name = "s-xml-source"; + src = pkgs.lispPackages.s-xml.src; + + patches = [ + ./0001-fix-definition-order-in-xml.lisp.patch + ]; + }; +in +depot.nix.buildLisp.library { + name = "s-xml"; + + srcs = map (f: src + ("/src/" + f)) [ + "package.lisp" + "xml.lisp" + "dom.lisp" + "lxml-dom.lisp" + "sxml-dom.lisp" + "xml-struct-dom.lisp" + ]; +} diff --git a/third_party/lisp/split-sequence.nix b/third_party/lisp/split-sequence.nix new file mode 100644 index 0000000000..4e8f723c31 --- /dev/null +++ b/third_party/lisp/split-sequence.nix @@ -0,0 +1,15 @@ +# split-sequence is a library for, well, splitting sequences apparently. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.split-sequence; +in depot.nix.buildLisp.library { + name = "split-sequence"; + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "vector.lisp" + "list.lisp" + "extended-sequence.lisp" + "api.lisp" + "documentation.lisp" + ]; +} diff --git a/third_party/lisp/trivial-backtrace.nix b/third_party/lisp/trivial-backtrace.nix new file mode 100644 index 0000000000..27949e8be1 --- /dev/null +++ b/third_party/lisp/trivial-backtrace.nix @@ -0,0 +1,15 @@ +# Imported from http://common-lisp.net/project/trivial-backtrace/trivial-backtrace.git +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.trivial-backtrace; +in depot.nix.buildLisp.library { + name = "trivial-backtrace"; + + srcs = map (f: src + ("/dev/" + f)) [ + "packages.lisp" + "utilities.lisp" + "backtrace.lisp" + "map-backtrace.lisp" + "fallback.lisp" + ]; +} diff --git a/third_party/lisp/trivial-features.nix b/third_party/lisp/trivial-features.nix new file mode 100644 index 0000000000..02abac54a8 --- /dev/null +++ b/third_party/lisp/trivial-features.nix @@ -0,0 +1,13 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.trivial-features; +in depot.nix.buildLisp.library { + name = "trivial-features"; + srcs = [ + { + sbcl = src + "/src/tf-sbcl.lisp"; + ecl = src + "/src/tf-ecl.lisp"; + ccl = src + "/src/tf-openmcl.lisp"; + } + ]; +} diff --git a/third_party/lisp/trivial-garbage.nix b/third_party/lisp/trivial-garbage.nix new file mode 100644 index 0000000000..74224df60d --- /dev/null +++ b/third_party/lisp/trivial-garbage.nix @@ -0,0 +1,9 @@ +# trivial-garbage provides a portable API to finalizers, weak +# hash-tables and weak pointers +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.trivial-garbage; +in depot.nix.buildLisp.library { + name = "trivial-garbage"; + srcs = [ (src + "/trivial-garbage.lisp") ]; +} diff --git a/third_party/lisp/trivial-gray-streams.nix b/third_party/lisp/trivial-gray-streams.nix new file mode 100644 index 0000000000..62a30f1e94 --- /dev/null +++ b/third_party/lisp/trivial-gray-streams.nix @@ -0,0 +1,13 @@ +# Portability library for CL gray streams. +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.trivial-gray-streams; +in depot.nix.buildLisp.library { + name = "trivial-gray-streams"; + srcs = [ + (src + "/package.lisp") + (src + "/streams.lisp") + ]; +} + + diff --git a/third_party/lisp/trivial-indent.nix b/third_party/lisp/trivial-indent.nix new file mode 100644 index 0000000000..70a6e19d48 --- /dev/null +++ b/third_party/lisp/trivial-indent.nix @@ -0,0 +1,10 @@ +{ depot, pkgs, ... }: + +let src = with pkgs; srcOnly lispPackages.trivial-indent; +in depot.nix.buildLisp.library { + name = "trivial-indent"; + + srcs = map (f: src + ("/" + f)) [ + "indent.lisp" + ]; +} diff --git a/third_party/lisp/trivial-ldap.nix b/third_party/lisp/trivial-ldap.nix new file mode 100644 index 0000000000..c85fe2accb --- /dev/null +++ b/third_party/lisp/trivial-ldap.nix @@ -0,0 +1,28 @@ +{ depot, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "rwiker"; + repo = "trivial-ldap"; + rev = "3b8f1ff85f29ea63e6ab2d0d27029d68b046faf8"; + sha256 = "1zaa4wnk5y5ff211pkg6dl27j4pjwh56hq0246slxsdxv6kvp1z9"; + }; +in +depot.nix.buildLisp.library { + name = "trivial-ldap"; + + deps = with depot.third_party.lisp; [ + usocket + cl-plus-ssl + cl-yacc + ]; + + srcs = map (f: src + ("/" + f)) [ + "package.lisp" + "trivial-ldap.lisp" + ]; + + brokenOn = [ + "ecl" # dynamic cffi + ]; +} diff --git a/third_party/lisp/trivial-mimes.nix b/third_party/lisp/trivial-mimes.nix new file mode 100644 index 0000000000..b097a3d0ee --- /dev/null +++ b/third_party/lisp/trivial-mimes.nix @@ -0,0 +1,26 @@ +{ depot, pkgs, ... }: + +let + src = with pkgs; srcOnly lispPackages.trivial-mimes; + + mime-types = pkgs.runCommand "mime-types.lisp" { } '' + substitute ${src}/mime-types.lisp $out \ + --replace /etc/mime.types ${src}/mime.types \ + --replace "(asdf:system-source-directory :trivial-mimes)" '"/bogus-dir"' + # We want to prevent an ASDF lookup at build time since this will + # generally fail — we are not using ASDF after all. + ''; + +in +depot.nix.buildLisp.library { + name = "trivial-mimes"; + + deps = [ + { + sbcl = depot.nix.buildLisp.bundled "uiop"; + default = depot.nix.buildLisp.bundled "asdf"; + } + ]; + + srcs = [ mime-types ]; +} diff --git a/third_party/lisp/uax-15.nix b/third_party/lisp/uax-15.nix new file mode 100644 index 0000000000..f98c029d36 --- /dev/null +++ b/third_party/lisp/uax-15.nix @@ -0,0 +1,43 @@ +{ depot, pkgs, ... }: + +let + inherit (pkgs) runCommand; + inherit (depot.nix.buildLisp) bundled; + src = with pkgs; srcOnly lispPackages.uax-15; +in +depot.nix.buildLisp.library { + name = "uax-15"; + + deps = with depot.third_party.lisp; [ + split-sequence + cl-ppcre + (bundled "asdf") + ]; + + srcs = [ + "${src}/src/package.lisp" + "${src}/src/utilities.lisp" + "${src}/src/trivial-utf-16.lisp" + + # uax-15 has runtime data files that need to have their references + # replaced with store paths. + # + # additionally there are some wonky variable usages of variables + # that are never defined, for which we patch in defvar statements. + (runCommand "precomputed-tables.lisp" { } '' + substitute ${src}/src/precomputed-tables.lisp precomputed-tables.lisp \ + --replace "(asdf:system-source-directory (asdf:find-system 'uax-15 nil))" \ + '"${src}/"' + + sed -i precomputed-tables.lisp \ + -e '10i(defvar *canonical-decomp-map*)' \ + -e '10i(defvar *compatible-decomp-map*)' \ + -e '10i(defvar *canonical-combining-class*)' + + cp precomputed-tables.lisp $out + '') + + "${src}/src/normalize-backend.lisp" + "${src}/src/uax-15.lisp" + ]; +} diff --git a/third_party/lisp/unix-opts.nix b/third_party/lisp/unix-opts.nix new file mode 100644 index 0000000000..2482961132 --- /dev/null +++ b/third_party/lisp/unix-opts.nix @@ -0,0 +1,12 @@ +# unix-opts is a portable command line argument parser +{ depot, pkgs, ... }: + + +let src = with pkgs; srcOnly lispPackages.unix-opts; +in depot.nix.buildLisp.library { + name = "unix-opts"; + + srcs = [ + "${src}/unix-opts.lisp" + ]; +} diff --git a/third_party/lisp/usocket-server.nix b/third_party/lisp/usocket-server.nix new file mode 100644 index 0000000000..5d6d04535f --- /dev/null +++ b/third_party/lisp/usocket-server.nix @@ -0,0 +1,19 @@ +# Universal socket library for Common Lisp (server side) +{ depot, pkgs, ... }: + +let + inherit (depot.nix) buildLisp; + src = with pkgs; srcOnly lispPackages.usocket-server; +in +buildLisp.library { + name = "usocket-server"; + + deps = with depot.third_party.lisp; [ + usocket + bordeaux-threads + ]; + + srcs = [ + "${src}/server.lisp" + ]; +} diff --git a/third_party/lisp/usocket.nix b/third_party/lisp/usocket.nix new file mode 100644 index 0000000000..589a3a0cfc --- /dev/null +++ b/third_party/lisp/usocket.nix @@ -0,0 +1,46 @@ +# Usocket is a portable socket library +{ depot, pkgs, ... }: + +let + inherit (depot.nix) buildLisp; + src = with pkgs; srcOnly lispPackages.usocket; +in +buildLisp.library { + name = "usocket"; + deps = with depot.third_party.lisp; [ + (buildLisp.bundled "asdf") + { + ecl = buildLisp.bundled "sb-bsd-sockets"; + sbcl = buildLisp.bundled "sb-bsd-sockets"; + } + split-sequence + ]; + + srcs = [ + # usocket also reads its version from ASDF, but there's further + # shenanigans happening there that I don't intend to support right + # now. Behold: + (builtins.toFile "usocket.asd" '' + (in-package :asdf) + (defsystem usocket + :version "0.8.3") + '') + ] ++ + # Now for the regularly scheduled programming: + (map (f: src + ("/" + f)) [ + "package.lisp" + "usocket.lisp" + "condition.lisp" + ] ++ [ + { sbcl = "${src}/backend/sbcl.lisp"; } + + # ECL actually has two files, it supports the SBCL backend, + # but usocket also has some ECL specific code + { ecl = "${src}/backend/sbcl.lisp"; } + { ecl = "${src}/backend/ecl.lisp"; } + + # Same for CCL + { ccl = "${src}/backend/openmcl.lisp"; } + { ccl = "${src}/backend/clozure.lisp"; } + ]); +} diff --git a/third_party/naersk/default.nix b/third_party/naersk/default.nix new file mode 100644 index 0000000000..bf4c55fe55 --- /dev/null +++ b/third_party/naersk/default.nix @@ -0,0 +1,3 @@ +{ depot, pkgs, ... }: + +pkgs.callPackage depot.third_party.sources.naersk { } diff --git a/third_party/napalm/default.nix b/third_party/napalm/default.nix new file mode 100644 index 0000000000..e85c360ba9 --- /dev/null +++ b/third_party/napalm/default.nix @@ -0,0 +1,7 @@ +{ depot, pkgs, ... }: + +pkgs.callPackage depot.third_party.sources.napalm { } // { + meta.ci.targets = [ + "napalm-registry" + ]; +} diff --git a/third_party/nix-snapshotter/default.nix b/third_party/nix-snapshotter/default.nix new file mode 100644 index 0000000000..58b30af25b --- /dev/null +++ b/third_party/nix-snapshotter/default.nix @@ -0,0 +1,13 @@ +# Imports the stable Nix build definitions for nix-snapshotter, a +# plugin to bring native support for Nix images to containerd +{ lib, pkgs, ... }: + +let + src = pkgs.fetchFromGitHub { + owner = "pdtpartners"; + repo = "nix-snapshotter"; + sha256 = "11sfy3kf046p8kacp7yh8ijjpp6php6q8wxlbya1v5q53h3980v1"; + rev = "6eb21bd3429535646da4aa396bb0c1f81a9b72c6"; + }; +in +pkgs.callPackage "${src}/package.nix" { } diff --git a/third_party/nixpkgs/default.nix b/third_party/nixpkgs/default.nix new file mode 100644 index 0000000000..747cf5a114 --- /dev/null +++ b/third_party/nixpkgs/default.nix @@ -0,0 +1,77 @@ +# This file imports the pinned nixpkgs sets and applies relevant +# modifications, such as our overlays. +# +# The actual source pinning happens via niv in //third_party/sources +# +# Note that the attribute exposed by this (third_party.nixpkgs) is +# "special" in that the fixpoint used as readTree's config parameter +# in //default.nix passes this attribute as the `pkgs` argument to all +# readTree derivations. + +{ depot ? { } +, externalArgs ? { } +, depotOverlays ? true +, localSystem ? externalArgs.localSystem or builtins.currentSystem +, crossSystem ? externalArgs.crossSystem or localSystem +, ... +}: + +let + # Arguments passed to both the stable nixpkgs and the main, unstable one. + # Includes everything but overlays which are only passed to unstable nixpkgs. + commonNixpkgsArgs = { + # allow users to inject their config into builds (e.g. to test CA derivations) + config = + (if externalArgs ? nixpkgsConfig then externalArgs.nixpkgsConfig else { }) + // { + allowUnfree = true; + allowUnfreeRedistributable = true; + allowBroken = true; + # Forbids our meta.ci attribute + # https://github.com/NixOS/nixpkgs/pull/191171#issuecomment-1260650771 + checkMeta = false; + }; + + inherit localSystem crossSystem; + }; + + # import the nixos-unstable package set, or optionally use the + # source (e.g. a path) specified by the `nixpkgsBisectPath` + # argument. This is intended for use-cases where the depot is + # bisected against nixpkgs to find the root cause of an issue in a + # channel bump. + nixpkgsSrc = externalArgs.nixpkgsBisectPath or depot.third_party.sources.nixpkgs; + + # Stable package set is imported, but not exposed, to overlay + # required packages into the unstable set. + stableNixpkgs = import depot.third_party.sources.nixpkgs-stable commonNixpkgsArgs; + + # Overlay for packages that should come from the stable channel + # instead (e.g. because something is broken in unstable). + # Use `stableNixpkgs` from above. + stableOverlay = _unstableSelf: unstableSuper: { + # weird memory access issues in SBCL on AMD; 2024-02-01 + sbcl = stableNixpkgs.sbcl; + }; + + # Overlay to expose the nixpkgs commits we are using to other Nix code. + commitsOverlay = _: _: { + nixpkgsCommits = { + unstable = depot.third_party.sources.nixpkgs.rev; + stable = depot.third_party.sources.nixpkgs-stable.rev; + }; + }; +in +import nixpkgsSrc (commonNixpkgsArgs // { + overlays = [ + commitsOverlay + stableOverlay + ] ++ (if depotOverlays then [ + depot.third_party.overlays.haskell + depot.third_party.overlays.emacs + depot.third_party.overlays.tvl + depot.third_party.overlays.ecl-static + depot.third_party.overlays.dhall + (import depot.third_party.sources.rust-overlay) + ] else [ ]); +}) diff --git a/third_party/nsfv/default.nix b/third_party/nsfv/default.nix new file mode 100644 index 0000000000..26d5488c42 --- /dev/null +++ b/third_party/nsfv/default.nix @@ -0,0 +1,23 @@ +# Real-time Noise Suppression Plugin (for PulseAudio). +# +# This should be invoked as a "ladspa" plugin for pulseaudio. +# +# https://github.com/werman/noise-suppression-for-voice +{ pkgs, lib, ... }: + +pkgs.stdenv.mkDerivation { + name = "noise-suppression-for-voice"; + + nativeBuildInputs = [ pkgs.cmake ]; + src = pkgs.fetchFromGitHub { + owner = "werman"; + repo = "noise-suppression-for-voice"; + rev = "cd5c79378ab9819cd85f4fd108f3c77a40fd66ac"; + sha256 = "10zh1al1bys60sjdd4p72qbp9jfb5wq1zaw33b595psgwmqpbckq"; + }; + + meta = with lib; { + description = "Real-time noise suppression LADSPA plugin"; + license = licenses.gpl3; + }; +} diff --git a/third_party/overlays/dhall/OWNERS b/third_party/overlays/dhall/OWNERS new file mode 100644 index 0000000000..a640227914 --- /dev/null +++ b/third_party/overlays/dhall/OWNERS @@ -0,0 +1 @@ +Profpatsch diff --git a/third_party/overlays/dhall/default.nix b/third_party/overlays/dhall/default.nix new file mode 100644 index 0000000000..4625035999 --- /dev/null +++ b/third_party/overlays/dhall/default.nix @@ -0,0 +1,30 @@ +{ ... }: + +self: super: + +let + + # binary releases of dhall tools, since the build in nixpkgs is + # broken most of the time. The binaries are also fully static + # builds, instead of the half-static crap that nixpkgs produces. + easy-dhall-nix = + import + (builtins.fetchTarball { + url = "https://github.com/justinwoo/easy-dhall-nix/archive/dce9acbb99776a7f1344db4751d6080380f76f57.tar.gz"; + sha256 = "0ckp6515gfvbxm08yyll87d9vg8sq2l21gwav2npzvwc3xz2lccf"; + }) + { pkgs = self; }; +in +{ + # ATTN: see the haskell overlay for some overrides we need. + + # dhall = easy-dhall-nix.dhall-simple; + # dhall-nix = easy-dhall-nix.dhall-nix-simple; + dhall-bash = easy-dhall-nix.dhall-bash-simple; + dhall-docs = easy-dhall-nix.dhall-docs-simple; + dhall-json = easy-dhall-nix.dhall-json-simple; + dhall-lsp-server = easy-dhall-nix.dhall-lsp-simple; + # not yet in dhall-simple + # dhall-nixpkgs = easy-dhall-nix.dhall-nixpkgs-simple; + dhall-yaml = easy-dhall-nix.dhall-yaml-simple; +} diff --git a/third_party/overlays/ecl-static.nix b/third_party/overlays/ecl-static.nix new file mode 100644 index 0000000000..d81075bdee --- /dev/null +++ b/third_party/overlays/ecl-static.nix @@ -0,0 +1,28 @@ +{ ... }: + +self: super: + +{ + # Statically linked ECL with statically linked dependencies. + # Works quite well, but solving this properly in a nixpkgs + # context will require figuring out cross compilation (for + # pkgsStatic), so we're gonna use this override for now. + # + # Note that ecl-static does mean that we have things + # statically linked against GMP and ECL which are LGPL. + # I believe this should be alright: The way ppl are gonna + # interact with the distributed binaries (i. e. the binary + # cache) is Nix in the depot monorepo, so the separability + # requirement should be satisfied: Source code or overriding + # would be available as ways to swap out the used GMP in the + # program. + # See https://www.gnu.org/licenses/gpl-faq.en.html#LGPLStaticVsDynamic + ecl-static = (super.pkgsMusl.ecl.override { + inherit (self.pkgsStatic) gmp libffi boehmgc; + }).overrideAttrs (drv: rec { + configureFlags = drv.configureFlags ++ [ + "--disable-shared" + "--with-dffi=no" # will fail at runtime anyways if statically linked + ]; + }); +} diff --git a/third_party/overlays/emacs.nix b/third_party/overlays/emacs.nix new file mode 100644 index 0000000000..341feb5015 --- /dev/null +++ b/third_party/overlays/emacs.nix @@ -0,0 +1,4 @@ +# Emacs overlay from https://github.com/nix-community/emacs-overlay +{ depot, ... }: + +import depot.third_party.sources.emacs-overlay diff --git a/third_party/overlays/haskell/.skip-subtree b/third_party/overlays/haskell/.skip-subtree new file mode 100644 index 0000000000..2a528eaa8a --- /dev/null +++ b/third_party/overlays/haskell/.skip-subtree @@ -0,0 +1 @@ +extra-pkgs need to be callPackage-ed diff --git a/third_party/overlays/haskell/OWNERS b/third_party/overlays/haskell/OWNERS new file mode 100644 index 0000000000..5f87d2f271 --- /dev/null +++ b/third_party/overlays/haskell/OWNERS @@ -0,0 +1,2 @@ +Profpatsch +sterni diff --git a/third_party/overlays/haskell/default.nix b/third_party/overlays/haskell/default.nix new file mode 100644 index 0000000000..5dbb8f45f8 --- /dev/null +++ b/third_party/overlays/haskell/default.nix @@ -0,0 +1,52 @@ +# Defines an overlay for overriding Haskell packages, for example to +# avoid breakage currently present in nixpkgs or to modify package +# versions. + +{ lib, ... }: + +self: super: # overlay parameters for the nixpkgs overlay + +let + haskellLib = self.haskell.lib.compose; +in +{ + haskellPackages = super.haskellPackages.override { + overrides = hsSelf: hsSuper: { + + ihp-hsx = lib.pipe hsSuper.ihp-hsx [ + (haskellLib.overrideSrc { + version = "1.1.0"; + src = "${self.fetchFromGitHub { + owner = "digitallyinduced"; + repo = "ihp"; + rev = "b5d47963c998ccd779aa5c3d46484338fd621f0d"; + sha256 = "sha256-M22W8VX4sRaeU2yVraR0S2t2VOwWGmoteD/M8TahdoE="; + }}/ihp-hsx"; + }) + haskellLib.doJailbreak + ]; + + pa-prelude = hsSelf.callPackage ./extra-pkgs/pa-prelude.nix { }; + pa-error-tree = hsSelf.callPackage ./extra-pkgs/pa-error-tree-0.1.0.0.nix { }; + pa-field-parser = hsSelf.callPackage ./extra-pkgs/pa-field-parser.nix { }; + pa-label = hsSelf.callPackage ./extra-pkgs/pa-label-0.1.0.1.nix { }; + pa-pretty = hsSelf.callPackage ./extra-pkgs/pa-pretty-0.1.1.0.nix { }; + pa-json = hsSelf.callPackage ./extra-pkgs/pa-json.nix { }; + pa-run-command = hsSelf.callPackage ./extra-pkgs/pa-run-command-0.1.0.0.nix { }; + }; + }; + + haskell = lib.recursiveUpdate super.haskell { + packages.ghc8107 = super.haskell.packages.ghc8107.override { + overrides = hsSelf: hsSuper: { + # TODO(sterni): TODO(grfn): patch xanthous to work with random-fu 0.3.*, + # so we can use GHC 9.0.2 and benefit from upstream binary cache. + random-fu = hsSelf.callPackage ./extra-pkgs/random-fu-0.2.nix { }; + rvar = hsSelf.callPackage ./extra-pkgs/rvar-0.2.nix { }; + + # TODO(grfn): port to brick 1.4 (EventM gains an additional type argument in 1.0) + brick = hsSelf.callPackage ./extra-pkgs/brick-0.73.nix { }; + }; + }; + }; +} diff --git a/third_party/overlays/haskell/extra-pkgs/brick-0.73.nix b/third_party/overlays/haskell/extra-pkgs/brick-0.73.nix new file mode 100644 index 0000000000..c5e2883c75 --- /dev/null +++ b/third_party/overlays/haskell/extra-pkgs/brick-0.73.nix @@ -0,0 +1,70 @@ +{ mkDerivation +, base +, bytestring +, config-ini +, containers +, contravariant +, data-clist +, deepseq +, directory +, dlist +, exceptions +, filepath +, lib +, microlens +, microlens-mtl +, microlens-th +, QuickCheck +, stm +, template-haskell +, text +, text-zipper +, transformers +, unix +, vector +, vty +, word-wrap +}: +mkDerivation { + pname = "brick"; + version = "0.73"; + sha256 = "741c8d0717f0ab5addd5d3acc88cb36d645a0c73907bde509b2fd9d9bc02039c"; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + base + bytestring + config-ini + containers + contravariant + data-clist + deepseq + directory + dlist + exceptions + filepath + microlens + microlens-mtl + microlens-th + stm + template-haskell + text + text-zipper + transformers + unix + vector + vty + word-wrap + ]; + testHaskellDepends = [ + base + containers + microlens + QuickCheck + vector + vty + ]; + homepage = "https://github.com/jtdaugherty/brick/"; + description = "A declarative terminal user interface library"; + license = lib.licenses.bsd3; +} diff --git a/third_party/overlays/haskell/extra-pkgs/pa-error-tree-0.1.0.0.nix b/third_party/overlays/haskell/extra-pkgs/pa-error-tree-0.1.0.0.nix new file mode 100644 index 0000000000..a38cd4efaa --- /dev/null +++ b/third_party/overlays/haskell/extra-pkgs/pa-error-tree-0.1.0.0.nix @@ -0,0 +1,10 @@ +{ mkDerivation, base, containers, lib, pa-prelude }: +mkDerivation { + pname = "pa-error-tree"; + version = "0.1.0.0"; + sha256 = "f82d3d905e8d9f0d31c81f31c424b9a95c65a8925517ccac92134f410cf8d639"; + libraryHaskellDepends = [ base containers pa-prelude ]; + homepage = "https://github.com/possehl-analytics/pa-hackage"; + description = "Collect a tree of errors and pretty-print"; + license = lib.licenses.bsd3; +} diff --git a/third_party/overlays/haskell/extra-pkgs/pa-field-parser.nix b/third_party/overlays/haskell/extra-pkgs/pa-field-parser.nix new file mode 100644 index 0000000000..a3c146ee09 --- /dev/null +++ b/third_party/overlays/haskell/extra-pkgs/pa-field-parser.nix @@ -0,0 +1,39 @@ +{ mkDerivation +, aeson +, aeson-better-errors +, attoparsec +, base +, case-insensitive +, containers +, lib +, pa-error-tree +, pa-prelude +, scientific +, semigroupoids +, template-haskell +, text +, time +}: +mkDerivation { + pname = "pa-field-parser"; + version = "0.3.0.0"; + sha256 = "528c2b6bf5ad6454861b059c7eb6924f4c32bcb5b8faa4c2389d9ddfd92fcd57"; + libraryHaskellDepends = [ + aeson + aeson-better-errors + attoparsec + base + case-insensitive + containers + pa-error-tree + pa-prelude + scientific + semigroupoids + template-haskell + text + time + ]; + homepage = "https://github.com/possehl-analytics/pa-hackage"; + description = "“Vertical” parsing of values"; + license = lib.licenses.bsd3; +} diff --git a/third_party/overlays/haskell/extra-pkgs/pa-json.nix b/third_party/overlays/haskell/extra-pkgs/pa-json.nix new file mode 100644 index 0000000000..8ce838b22c --- /dev/null +++ b/third_party/overlays/haskell/extra-pkgs/pa-json.nix @@ -0,0 +1,43 @@ +{ mkDerivation +, aeson +, aeson-better-errors +, aeson-pretty +, base +, base64-bytestring +, bytestring +, containers +, lib +, pa-error-tree +, pa-field-parser +, pa-label +, pa-prelude +, scientific +, text +, time +, vector +}: +mkDerivation { + pname = "pa-json"; + version = "0.3.0.0"; + sha256 = "45e79765e57e21400f3f3b1e86094473fac61d298618d7e34f6cad4988d8923b"; + libraryHaskellDepends = [ + aeson + aeson-better-errors + aeson-pretty + base + base64-bytestring + bytestring + containers + pa-error-tree + pa-field-parser + pa-label + pa-prelude + scientific + text + time + vector + ]; + homepage = "https://github.com/possehl-analytics/pa-hackage"; + description = "Our JSON parsers/encoders"; + license = lib.licenses.bsd3; +} diff --git a/third_party/overlays/haskell/extra-pkgs/pa-label-0.1.0.1.nix b/third_party/overlays/haskell/extra-pkgs/pa-label-0.1.0.1.nix new file mode 100644 index 0000000000..1da78260cc --- /dev/null +++ b/third_party/overlays/haskell/extra-pkgs/pa-label-0.1.0.1.nix @@ -0,0 +1,10 @@ +{ mkDerivation, base, lib }: +mkDerivation { + pname = "pa-label"; + version = "0.1.0.1"; + sha256 = "0131ab7718d910a94cd8cc881e51b7371a060dadfeabc8fd78513a7f27ee8d35"; + libraryHaskellDepends = [ base ]; + homepage = "https://github.com/possehl-analytics/pa-hackage"; + description = "Labels, and labelled tuples and enums (GHC >9.2)"; + license = lib.licenses.bsd3; +} diff --git a/third_party/overlays/haskell/extra-pkgs/pa-prelude.nix b/third_party/overlays/haskell/extra-pkgs/pa-prelude.nix new file mode 100644 index 0000000000..17e1996ab6 --- /dev/null +++ b/third_party/overlays/haskell/extra-pkgs/pa-prelude.nix @@ -0,0 +1,43 @@ +{ mkDerivation +, base +, bytestring +, containers +, error +, exceptions +, lib +, mtl +, profunctors +, PyF +, scientific +, semigroupoids +, template-haskell +, text +, these +, validation-selective +, vector +}: +mkDerivation { + pname = "pa-prelude"; + version = "0.2.0.0"; + sha256 = "68015f7c19e9c618fc04e2516baccfce52af24efb9ca1480162c9ea0aef7f301"; + libraryHaskellDepends = [ + base + bytestring + containers + error + exceptions + mtl + profunctors + PyF + scientific + semigroupoids + template-haskell + text + these + validation-selective + vector + ]; + homepage = "https://github.com/possehl-analytics/pa-hackage"; + description = "The Possehl Analytics Prelude"; + license = lib.licenses.bsd3; +} diff --git a/third_party/overlays/haskell/extra-pkgs/pa-pretty-0.1.1.0.nix b/third_party/overlays/haskell/extra-pkgs/pa-pretty-0.1.1.0.nix new file mode 100644 index 0000000000..d6dadef849 --- /dev/null +++ b/third_party/overlays/haskell/extra-pkgs/pa-pretty-0.1.1.0.nix @@ -0,0 +1,29 @@ +{ mkDerivation +, aeson +, aeson-pretty +, ansi-terminal +, base +, hscolour +, lib +, nicify-lib +, pa-prelude +, text +}: +mkDerivation { + pname = "pa-pretty"; + version = "0.1.1.0"; + sha256 = "da925a7cf2ac49c5769d7ebd08c2599b537efe45b3d506bf4d7c8673633ef6c9"; + libraryHaskellDepends = [ + aeson + aeson-pretty + ansi-terminal + base + hscolour + nicify-lib + pa-prelude + text + ]; + homepage = "https://github.com/possehl-analytics/pa-hackage"; + description = "Some pretty-printing helpers"; + license = lib.licenses.bsd3; +} diff --git a/third_party/overlays/haskell/extra-pkgs/pa-run-command-0.1.0.0.nix b/third_party/overlays/haskell/extra-pkgs/pa-run-command-0.1.0.0.nix new file mode 100644 index 0000000000..b12eb5efbf --- /dev/null +++ b/third_party/overlays/haskell/extra-pkgs/pa-run-command-0.1.0.0.nix @@ -0,0 +1,25 @@ +{ mkDerivation +, base +, bytestring +, lib +, monad-logger +, pa-prelude +, text +, typed-process +}: +mkDerivation { + pname = "pa-run-command"; + version = "0.1.0.0"; + sha256 = "37837e0cddedc9b615063f0357115739c53b5dcb8af82ce86a95a3a5c88c29a3"; + libraryHaskellDepends = [ + base + bytestring + monad-logger + pa-prelude + text + typed-process + ]; + homepage = "https://github.com/possehl-analytics/pa-hackage"; + description = "Helper functions for spawning subprocesses"; + license = lib.licenses.bsd3; +} diff --git a/third_party/overlays/haskell/extra-pkgs/random-fu-0.2.nix b/third_party/overlays/haskell/extra-pkgs/random-fu-0.2.nix new file mode 100644 index 0000000000..1626eca7be --- /dev/null +++ b/third_party/overlays/haskell/extra-pkgs/random-fu-0.2.nix @@ -0,0 +1,41 @@ +{ mkDerivation +, base +, erf +, lib +, math-functions +, monad-loops +, mtl +, random +, random-shuffle +, random-source +, rvar +, syb +, template-haskell +, transformers +, vector +}: +mkDerivation { + pname = "random-fu"; + version = "0.2.7.7"; + sha256 = "8466bcfb5290bdc30a571c91e1eb526c419ea9773bc118996778b516cfc665ca"; + revision = "1"; + editedCabalFile = "16nhymfriygqr2by9v72vdzv93v6vhd9z07pgaji4zvv66jikv82"; + libraryHaskellDepends = [ + base + erf + math-functions + monad-loops + mtl + random + random-shuffle + random-source + rvar + syb + template-haskell + transformers + vector + ]; + homepage = "https://github.com/mokus0/random-fu"; + description = "Random number generation"; + license = lib.licenses.publicDomain; +} diff --git a/third_party/overlays/haskell/extra-pkgs/rvar-0.2.nix b/third_party/overlays/haskell/extra-pkgs/rvar-0.2.nix new file mode 100644 index 0000000000..c00f5a1a8d --- /dev/null +++ b/third_party/overlays/haskell/extra-pkgs/rvar-0.2.nix @@ -0,0 +1,25 @@ +{ mkDerivation +, base +, lib +, MonadPrompt +, mtl +, random-source +, transformers +}: +mkDerivation { + pname = "rvar"; + version = "0.2.0.6"; + sha256 = "01e18875ffde43f9591a8acd9f60c9c51704a026e51c1a6797faecd1c7ae8cd3"; + revision = "1"; + editedCabalFile = "1jn9ivlj3k65n8d9sfsp882m5lvni1ah79mk0cvkz91pgywvkiyq"; + libraryHaskellDepends = [ + base + MonadPrompt + mtl + random-source + transformers + ]; + homepage = "https://github.com/mokus0/random-fu"; + description = "Random Variables"; + license = lib.licenses.publicDomain; +} diff --git a/third_party/overlays/patches/.skip-tree b/third_party/overlays/patches/.skip-tree new file mode 100644 index 0000000000..86eae51a6d --- /dev/null +++ b/third_party/overlays/patches/.skip-tree @@ -0,0 +1 @@ +No readTree-compatible files. diff --git a/third_party/overlays/patches/0001-configure-ac-version.patch b/third_party/overlays/patches/0001-configure-ac-version.patch new file mode 100644 index 0000000000..fa2575cb93 --- /dev/null +++ b/third_party/overlays/patches/0001-configure-ac-version.patch @@ -0,0 +1,13 @@ +diff --git a/configure.ac b/configure.ac +index e861e42..018c19c 100644 +--- a/configure.ac ++++ b/configure.ac +@@ -26,7 +26,7 @@ + #;**********************************************************************; + + AC_INIT([tpm2-pkcs11], +- [m4_esyscmd_s([git describe --tags --always --dirty])], ++ [git-@VERSION@], + [https://github.com/tpm2-software/tpm2-pkcs11/issues], + [], + [https://github.com/tpm2-software/tpm2-pkcs11]) diff --git a/third_party/overlays/patches/buf-tests-dont-use-file-transport.patch b/third_party/overlays/patches/buf-tests-dont-use-file-transport.patch new file mode 100644 index 0000000000..34be80eb36 --- /dev/null +++ b/third_party/overlays/patches/buf-tests-dont-use-file-transport.patch @@ -0,0 +1,64 @@ +commit e9219b88de5ed37af337ee2d2e71e7ec7c0aad1b +Author: Robbert van Ginkel <rvanginkel@buf.build> +Date: Thu Oct 20 16:43:28 2022 -0400 + + Fix git unit test by using fake git server rather than file:// (#1518) + + More recent versions of git fix a CVE by disabling some usage of the + `file://` transport, see + https://github.blog/2022-10-18-git-security-vulnerabilities-announced/#cve-2022-39253. + We were using this transport in tests. + + Instead, use https://git-scm.com/docs/git-http-backend to serve up this + repository locally so we don't have to use the file protocol. This + should be a more accurate tests, since we mostly expect submodules to + come from servers. + +diff --git a/.golangci.yml b/.golangci.yml +index 318d1171..865e03e7 100644 +--- a/.golangci.yml ++++ b/.golangci.yml +@@ -136,3 +136,8 @@ issues: + - linters: + - containedctx + path: private/bufpkg/bufmodule/bufmoduleprotocompile ++ # We should be able to use net/http/cgi in a unit test, in addition the CVE mentions only versions of go < 1.6.3 are affected. ++ - linters: ++ - gosec ++ path: private/pkg/git/git_test.go ++ text: "G504:" +diff --git a/private/pkg/git/git_test.go b/private/pkg/git/git_test.go +index 7b77b6cd..7132054e 100644 +--- a/private/pkg/git/git_test.go ++++ b/private/pkg/git/git_test.go +@@ -17,6 +17,8 @@ package git + import ( + "context" + "errors" ++ "net/http/cgi" ++ "net/http/httptest" + "os" + "os/exec" + "path/filepath" +@@ -213,6 +215,21 @@ func createGitDirs( + runCommand(ctx, t, container, runner, "git", "-C", submodulePath, "add", "test.proto") + runCommand(ctx, t, container, runner, "git", "-C", submodulePath, "commit", "-m", "commit 0") + ++ gitExecPath, err := command.RunStdout(ctx, container, runner, "git", "--exec-path") ++ require.NoError(t, err) ++ t.Log(filepath.Join(string(gitExecPath), "git-http-backend")) ++ // https://git-scm.com/docs/git-http-backend#_description ++ f, err := os.Create(filepath.Join(submodulePath, ".git", "git-daemon-export-ok")) ++ require.NoError(t, err) ++ require.NoError(t, f.Close()) ++ server := httptest.NewServer(&cgi.Handler{ ++ Path: filepath.Join(strings.TrimSpace(string(gitExecPath)), "git-http-backend"), ++ Dir: submodulePath, ++ Env: []string{"GIT_PROJECT_ROOT=" + submodulePath}, ++ }) ++ t.Cleanup(server.Close) ++ submodulePath = server.URL ++ + originPath := filepath.Join(tmpDir, "origin") + require.NoError(t, os.MkdirAll(originPath, 0777)) + runCommand(ctx, t, container, runner, "git", "-C", originPath, "init") diff --git a/third_party/overlays/patches/clickhouse-support-reading-arrow-LargeListArray.patch b/third_party/overlays/patches/clickhouse-support-reading-arrow-LargeListArray.patch new file mode 100644 index 0000000000..9e79aa7267 --- /dev/null +++ b/third_party/overlays/patches/clickhouse-support-reading-arrow-LargeListArray.patch @@ -0,0 +1,106 @@ +From cdea2e8ad98995202ce81c9c030f2ae64d73b05a Mon Sep 17 00:00:00 2001 +From: edef <edef@edef.eu> +Date: Mon, 30 Oct 2023 08:08:10 +0000 +Subject: [PATCH] Support reading arrow::LargeListArray + +--- + .../Formats/Impl/ArrowColumnToCHColumn.cpp | 33 +++++++++++++++---- + 1 file changed, 26 insertions(+), 7 deletions(-) + +diff --git a/src/Processors/Formats/Impl/ArrowColumnToCHColumn.cpp b/src/Processors/Formats/Impl/ArrowColumnToCHColumn.cpp +index 6f9d49498f2..b93846cd4eb 100644 +--- a/src/Processors/Formats/Impl/ArrowColumnToCHColumn.cpp ++++ b/src/Processors/Formats/Impl/ArrowColumnToCHColumn.cpp +@@ -436,6 +436,22 @@ static ColumnPtr readByteMapFromArrowColumn(std::shared_ptr<arrow::ChunkedArray> + return nullmap_column; + } + ++template <typename T> ++struct ArrowOffsetArray; ++ ++template <> ++struct ArrowOffsetArray<arrow::ListArray> ++{ ++ using type = arrow::Int32Array; ++}; ++ ++template <> ++struct ArrowOffsetArray<arrow::LargeListArray> ++{ ++ using type = arrow::Int64Array; ++}; ++ ++template <typename ArrowListArray> + static ColumnPtr readOffsetsFromArrowListColumn(std::shared_ptr<arrow::ChunkedArray> & arrow_column) + { + auto offsets_column = ColumnUInt64::create(); +@@ -444,9 +460,9 @@ static ColumnPtr readOffsetsFromArrowListColumn(std::shared_ptr<arrow::ChunkedAr + + for (int chunk_i = 0, num_chunks = arrow_column->num_chunks(); chunk_i < num_chunks; ++chunk_i) + { +- arrow::ListArray & list_chunk = dynamic_cast<arrow::ListArray &>(*(arrow_column->chunk(chunk_i))); ++ ArrowListArray & list_chunk = dynamic_cast<ArrowListArray &>(*(arrow_column->chunk(chunk_i))); + auto arrow_offsets_array = list_chunk.offsets(); +- auto & arrow_offsets = dynamic_cast<arrow::Int32Array &>(*arrow_offsets_array); ++ auto & arrow_offsets = dynamic_cast<ArrowOffsetArray<ArrowListArray>::type &>(*arrow_offsets_array); + + /* + * CH uses element size as "offsets", while arrow uses actual offsets as offsets. +@@ -602,13 +618,14 @@ static ColumnPtr readColumnWithIndexesData(std::shared_ptr<arrow::ChunkedArray> + } + } + ++template <typename ArrowListArray> + static std::shared_ptr<arrow::ChunkedArray> getNestedArrowColumn(std::shared_ptr<arrow::ChunkedArray> & arrow_column) + { + arrow::ArrayVector array_vector; + array_vector.reserve(arrow_column->num_chunks()); + for (int chunk_i = 0, num_chunks = arrow_column->num_chunks(); chunk_i < num_chunks; ++chunk_i) + { +- arrow::ListArray & list_chunk = dynamic_cast<arrow::ListArray &>(*(arrow_column->chunk(chunk_i))); ++ ArrowListArray & list_chunk = dynamic_cast<ArrowListArray &>(*(arrow_column->chunk(chunk_i))); + + /* + * It seems like arrow::ListArray::values() (nested column data) might or might not be shared across chunks. +@@ -819,12 +836,12 @@ static ColumnWithTypeAndName readColumnFromArrowColumn( + key_type_hint = map_type_hint->getKeyType(); + } + } +- auto arrow_nested_column = getNestedArrowColumn(arrow_column); ++ auto arrow_nested_column = getNestedArrowColumn<arrow::ListArray>(arrow_column); + auto nested_column = readColumnFromArrowColumn(arrow_nested_column, column_name, format_name, false, dictionary_infos, allow_null_type, skip_columns_with_unsupported_types, skipped, date_time_overflow_behavior, nested_type_hint, true); + if (skipped) + return {}; + +- auto offsets_column = readOffsetsFromArrowListColumn(arrow_column); ++ auto offsets_column = readOffsetsFromArrowListColumn<arrow::ListArray>(arrow_column); + + const auto * tuple_column = assert_cast<const ColumnTuple *>(nested_column.column.get()); + const auto * tuple_type = assert_cast<const DataTypeTuple *>(nested_column.type.get()); +@@ -846,7 +863,9 @@ static ColumnWithTypeAndName readColumnFromArrowColumn( + return {std::move(map_column), std::move(map_type), column_name}; + } + case arrow::Type::LIST: ++ case arrow::Type::LARGE_LIST: + { ++ bool is_large = arrow_column->type()->id() == arrow::Type::LARGE_LIST; + DataTypePtr nested_type_hint; + if (type_hint) + { +@@ -854,11 +873,11 @@ static ColumnWithTypeAndName readColumnFromArrowColumn( + if (array_type_hint) + nested_type_hint = array_type_hint->getNestedType(); + } +- auto arrow_nested_column = getNestedArrowColumn(arrow_column); ++ auto arrow_nested_column = is_large ? getNestedArrowColumn<arrow::LargeListArray>(arrow_column) : getNestedArrowColumn<arrow::ListArray>(arrow_column); + auto nested_column = readColumnFromArrowColumn(arrow_nested_column, column_name, format_name, false, dictionary_infos, allow_null_type, skip_columns_with_unsupported_types, skipped, date_time_overflow_behavior, nested_type_hint); + if (skipped) + return {}; +- auto offsets_column = readOffsetsFromArrowListColumn(arrow_column); ++ auto offsets_column = is_large ? readOffsetsFromArrowListColumn<arrow::LargeListArray>(arrow_column) : readOffsetsFromArrowListColumn<arrow::ListArray>(arrow_column); + auto array_column = ColumnArray::create(nested_column.column, offsets_column); + auto array_type = std::make_shared<DataTypeArray>(nested_column.type); + return {std::move(array_column), std::move(array_type), column_name}; +-- +2.42.0 + diff --git a/third_party/overlays/patches/crate2nix-run-tests-in-build-source.patch b/third_party/overlays/patches/crate2nix-run-tests-in-build-source.patch new file mode 100644 index 0000000000..52793270e6 --- /dev/null +++ b/third_party/overlays/patches/crate2nix-run-tests-in-build-source.patch @@ -0,0 +1,69 @@ +From 7cf084f73f7d15fe0538a625182fa7179c083b3d Mon Sep 17 00:00:00 2001 +From: Raito Bezarius <masterancpp@gmail.com> +Date: Tue, 16 Jan 2024 02:10:48 +0100 +Subject: [PATCH] fix(template): run tests in `/build/source` instead `/build` + +Previously, the source tree was located inline in `/build` during tests, this was a mistake +because the crates more than often are built in `/build/source` as per the `sourceRoot` system. + +This can cause issues with test binaries hardcoding `/build/source/...` as their choice for doing things, +causing them to be confused in the test phase which is relocated without rewriting the paths inside test binaries. + +We fix that by relocating ourselves in the right hierarchy. + +This is a "simple" fix in the sense that more edge cases could exist but they are hard to reason about +because they would be crates using custom `sourceRoot`, i.e. having `crate.sourceRoot` set and then it becomes +a bit hard to reproduce the hierarchy, you need to analyze whether the path is absolute or relative, + +If it's relative, you can just reuse it and reproduce that specific hierarchy. +If it's absolute, you need to cut the "absolute" meaningless part, e.g. `$NIX_BUILD_TOP/` and proceed like +it's a relative path IMHO. +--- + crate2nix/Cargo.nix | 10 ++++++++++ + crate2nix/templates/nix/crate2nix/default.nix | 10 ++++++++++ + +diff --git a/Cargo.nix b/Cargo.nix +index 6ef7a49..172ff34 100644 +--- a/Cargo.nix ++++ b/Cargo.nix +@@ -2889,6 +2889,16 @@ rec { + # recreate a file hierarchy as when running tests with cargo + + # the source for test data ++ # It's necessary to locate the source in $NIX_BUILD_TOP/source/ ++ # instead of $NIX_BUILD_TOP/ ++ # because we compiled those test binaries in the former and not the latter. ++ # So all paths will expect source tree to be there and not in the build top directly. ++ # For example: $NIX_BUILD_TOP := /build in general, if you ask yourself. ++ # TODO(raitobezarius): I believe there could be more edge cases if `crate.sourceRoot` ++ # do exist but it's very hard to reason about them, so let's wait until the first bug report. ++ mkdir -p source/ ++ cd source/ ++ + ${pkgs.buildPackages.xorg.lndir}/bin/lndir ${crate.src} + + # build outputs +diff --git a/crate2nix/templates/nix/crate2nix/default.nix b/crate2nix/templates/nix/crate2nix/default.nix +index e4fc2e9..dfb14c4 100644 +--- a/templates/nix/crate2nix/default.nix ++++ b/templates/nix/crate2nix/default.nix +@@ -135,6 +135,16 @@ rec { + # recreate a file hierarchy as when running tests with cargo + + # the source for test data ++ # It's necessary to locate the source in $NIX_BUILD_TOP/source/ ++ # instead of $NIX_BUILD_TOP/ ++ # because we compiled those test binaries in the former and not the latter. ++ # So all paths will expect source tree to be there and not in the build top directly. ++ # For example: $NIX_BUILD_TOP := /build in general, if you ask yourself. ++ # TODO(raitobezarius): I believe there could be more edge cases if `crate.sourceRoot` ++ # do exist but it's very hard to reason about them, so let's wait until the first bug report. ++ mkdir -p source/ ++ cd source/ ++ + ${pkgs.buildPackages.xorg.lndir}/bin/lndir ${crate.src} + + # build outputs +-- +2.43.0 + diff --git a/third_party/overlays/patches/evans-add-support-for-unix-domain-sockets.patch b/third_party/overlays/patches/evans-add-support-for-unix-domain-sockets.patch new file mode 100644 index 0000000000..c66528f538 --- /dev/null +++ b/third_party/overlays/patches/evans-add-support-for-unix-domain-sockets.patch @@ -0,0 +1,39 @@ +From 55d7e7af7c56f678eb817059417241bb61ee5181 Mon Sep 17 00:00:00 2001 +From: Florian Klink <flokli@flokli.de> +Date: Sun, 8 Oct 2023 11:00:27 +0200 +Subject: [PATCH] add support for unix domain sockets + +grpc.NewClient already supports connecting to unix domain sockets, and +accepts a string anyways. + +As a quick fix, detect the `address` starting with `unix://` and don't +add the port. + +In the long term, we might want to deprecate `host` and `port` cmdline +args in favor of a single `address` arg. +--- + mode/common.go | 8 +++++++- + 1 file changed, 7 insertions(+), 1 deletion(-) + +diff --git a/mode/common.go b/mode/common.go +index dfc7839..55f1e36 100644 +--- a/mode/common.go ++++ b/mode/common.go +@@ -13,7 +13,13 @@ import ( + ) + + func newGRPCClient(cfg *config.Config) (grpc.Client, error) { +- addr := fmt.Sprintf("%s:%s", cfg.Server.Host, cfg.Server.Port) ++ addr := cfg.Server.Host ++ ++ // as long as the address doesn't start with unix, also add the port. ++ if !strings.HasPrefix(cfg.Server.Host, "unix://") { ++ addr = fmt.Sprintf("%s:%s", cfg.Server.Host, cfg.Server.Port) ++ } ++ + if cfg.Request.Web { + //TODO: remove second arg + return grpc.NewWebClient(addr, cfg.Server.Reflection, false, "", "", "", grpc.Headers(cfg.Request.Header)), nil +-- +2.42.0 + diff --git a/third_party/overlays/patches/notmuch-dottime.patch b/third_party/overlays/patches/notmuch-dottime.patch new file mode 100644 index 0000000000..7a9cfc6cc2 --- /dev/null +++ b/third_party/overlays/patches/notmuch-dottime.patch @@ -0,0 +1,81 @@ +From 569438172fa0e38129de4e61a72e06eff3330dca Mon Sep 17 00:00:00 2001 +From: Vincent Ambo <tazjin@google.com> +Date: Thu, 10 Dec 2020 10:53:47 +0100 +Subject: [PATCH] time: Use dottime for formatting non-relative timestamps + +--- + notmuch-time.c | 10 +++++----- + util/gmime-extra.c | 7 +++++-- + util/gmime-extra.h | 2 ++ + 3 files changed, 12 insertions(+), 7 deletions(-) + +diff --git a/notmuch-time.c b/notmuch-time.c +index cc7ffc23..3030a667 100644 +--- a/notmuch-time.c ++++ b/notmuch-time.c +@@ -50,8 +50,8 @@ notmuch_time_relative_date (const void *ctx, time_t then) + time_t delta; + char *result; + +- localtime_r (&now, &tm_now); +- localtime_r (&then, &tm_then); ++ gmtime_r (&now, &tm_now); ++ gmtime_r (&then, &tm_then); + + result = talloc_zero_size (ctx, RELATIVE_DATE_MAX); + if (result == NULL) +@@ -78,16 +78,16 @@ notmuch_time_relative_date (const void *ctx, time_t then) + if (tm_then.tm_wday == tm_now.tm_wday && + delta < DAY) { + strftime (result, RELATIVE_DATE_MAX, +- "Today %R", &tm_then); /* Today 12:30 */ ++ "Today %k·%M", &tm_then); /* Today 12·30 */ + return result; + } else if ((tm_now.tm_wday + 7 - tm_then.tm_wday) % 7 == 1) { + strftime (result, RELATIVE_DATE_MAX, +- "Yest. %R", &tm_then); /* Yest. 12:30 */ ++ "Yest. %k·%M", &tm_then); /* Yest. 12·30 */ + return result; + } else { + if (tm_then.tm_wday != tm_now.tm_wday) { + strftime (result, RELATIVE_DATE_MAX, +- "%a. %R", &tm_then); /* Mon. 12:30 */ ++ "%a. %k·%M", &tm_then); /* Mon. 12·30 */ + return result; + } + } +diff --git a/util/gmime-extra.c b/util/gmime-extra.c +index 04d8ed3d..868a2f69 100644 +--- a/util/gmime-extra.c ++++ b/util/gmime-extra.c +@@ -131,10 +131,13 @@ g_mime_message_get_date_string (void *ctx, GMimeMessage *message) + GDateTime *parsed_date = g_mime_message_get_date (message); + + if (parsed_date) { +- char *date = g_mime_utils_header_format_date (parsed_date); ++ char *date = g_date_time_format( ++ parsed_date, ++ "%a, %d %b %Y %H·%M%z" ++ ); + return g_string_talloc_strdup (ctx, date); + } else { +- return talloc_strdup (ctx, "Thu, 01 Jan 1970 00:00:00 +0000"); ++ return talloc_strdup (ctx, "Thu, 01 Jan 1970 00·00:00"); + } + } + +diff --git a/util/gmime-extra.h b/util/gmime-extra.h +index 094309ec..e6c98f8d 100644 +--- a/util/gmime-extra.h ++++ b/util/gmime-extra.h +@@ -1,5 +1,7 @@ + #ifndef _GMIME_EXTRA_H + #define _GMIME_EXTRA_H ++#include <glib.h> ++#include <glib/gprintf.h> + #include <gmime/gmime.h> + #include <talloc.h> + +-- +2.29.2.576.ga3fc446d84-goog + diff --git a/third_party/overlays/patches/tpm2-pkcs11.nix b/third_party/overlays/patches/tpm2-pkcs11.nix new file mode 100644 index 0000000000..2e7db7aca3 --- /dev/null +++ b/third_party/overlays/patches/tpm2-pkcs11.nix @@ -0,0 +1,105 @@ +{ stdenv +, lib +, fetchFromGitHub +, substituteAll +, pkg-config +, autoreconfHook +, autoconf-archive +, makeWrapper +, patchelf +, tpm2-tss +, tpm2-tools +, opensc +, openssl +, sqlite +, python3 +, glibc +, libyaml +, abrmdSupport ? true +, tpm2-abrmd ? null +}: + +stdenv.mkDerivation rec { + pname = "tpm2-pkcs11"; + version = "1.8.0"; + + src = fetchFromGitHub { + owner = "tpm2-software"; + repo = pname; + rev = version; + sha256 = "sha256-f5wi0nIM071yaQCwPkY1agKc7OEQa/IxHJc4V2i0Q9I="; + }; + + patches = lib.singleton ( + substituteAll { + src = ./0001-configure-ac-version.patch; + VERSION = version; + }); + + # The preConfigure phase doesn't seem to be working here + # ./bootstrap MUST be executed as the first step, before all + # of the autoreconfHook stuff + postPatch = '' + ./bootstrap + ''; + + nativeBuildInputs = [ + pkg-config + autoreconfHook + autoconf-archive + makeWrapper + patchelf + ]; + buildInputs = [ + tpm2-tss + tpm2-tools + opensc + openssl + sqlite + libyaml + (python3.withPackages (ps: with ps; [ packaging pyyaml cryptography pyasn1-modules tpm2-pytss ])) + ]; + + outputs = [ "out" "bin" "dev" ]; + + dontStrip = true; + dontPatchELF = true; + + # To be able to use the userspace resource manager, the RUNPATH must + # explicitly include the tpm2-abrmd shared libraries. + preFixup = + let + rpath = lib.makeLibraryPath ( + (lib.optional abrmdSupport tpm2-abrmd) + ++ [ + tpm2-tss + sqlite + openssl + glibc + libyaml + ] + ); + in + '' + patchelf \ + --set-rpath ${rpath} \ + ${lib.optionalString abrmdSupport "--add-needed ${lib.makeLibraryPath [tpm2-abrmd]}/libtss2-tcti-tabrmd.so"} \ + --add-needed ${lib.makeLibraryPath [tpm2-tss]}/libtss2-tcti-device.so \ + $out/lib/libtpm2_pkcs11.so.0.0.0 + ''; + + postInstall = '' + mkdir -p $bin/bin/ $bin/share/tpm2_pkcs11/ + mv ./tools/* $bin/share/tpm2_pkcs11/ + makeWrapper $bin/share/tpm2_pkcs11/tpm2_ptool.py $bin/bin/tpm2_ptool \ + --prefix PATH : ${lib.makeBinPath [ tpm2-tools ]} + ''; + + meta = with lib; { + description = "A PKCS#11 interface for TPM2 hardware"; + homepage = "https://github.com/tpm2-software/tpm2-pkcs11"; + license = licenses.bsd2; + platforms = platforms.linux; + maintainers = with maintainers; [ matthiasbeyer ]; + }; +} diff --git a/third_party/overlays/tvl.nix b/third_party/overlays/tvl.nix new file mode 100644 index 0000000000..861c66694a --- /dev/null +++ b/third_party/overlays/tvl.nix @@ -0,0 +1,153 @@ +# This overlay is used to make TVL-specific modifications in the +# nixpkgs tree, where required. +{ lib, depot, localSystem, ... }: + +self: super: +depot.nix.readTree.drvTargets { + nix_2_3 = (super.nix_2_3.override { + # flaky tests, long painful build, see https://github.com/NixOS/nixpkgs/pull/266443 + withAWS = false; + }); + nix = self.nix_2_3; + nix_latest = super.nix.override ({ + # flaky tests, long painful build, see https://github.com/NixOS/nixpkgs/pull/266443 + withAWS = false; + }); + + # To match telega in emacs-overlay or wherever + tdlib = super.tdlib.overrideAttrs (_: { + version = "1.8.23"; + src = self.fetchFromGitHub { + owner = "tdlib"; + repo = "td"; + rev = "27c3eaeb4964bd5f18d8488e354abde1a4383e49"; + sha256 = "14f65dfmg2p5hyvi3lffvvazwcd3i3jrrw3c2pwrc5yfgxk3662g"; + }; + }); + + home-manager = super.home-manager.overrideAttrs (_: { + src = depot.third_party.sources.home-manager; + version = "git-" + + builtins.substring 0 7 depot.third_party.sources.home-manager.rev; + }); + + # Add our Emacs packages to the fixpoint + emacsPackagesFor = emacs: ( + (super.emacsPackagesFor emacs).overrideScope' (eself: esuper: { + tvlPackages = depot.tools.emacs-pkgs // depot.third_party.emacs; + + # Use the notmuch from nixpkgs instead of from the Emacs + # overlay, to avoid versions being out of sync. + notmuch = super.notmuch.emacs; + + # Build EXWM with the depot sources instead. + depotExwm = eself.callPackage depot.third_party.exwm.override { }; + + # Workaround for magit checking the git version at load time + magit = esuper.magit.overrideAttrs (_: { + propagatedNativeBuildInputs = [ + self.git + ]; + }); + + # Pin xelb to a newer one until the new maintainers do a release. + xelb = eself.trivialBuild { + pname = "xelb"; + version = "0.19-dev"; # invented version, last actual release was 0.18 + + src = self.fetchFromGitHub { + owner = "emacs-exwm"; + repo = "xelb"; + rev = "86089eba2de6c818bfa2fac075cb7ad876262798"; + sha256 = "1mmlrd2zpcwiv8gh10y7lrpflnbmsycdascrxjr3bfcwa8yx7901"; + }; + }; + }) + ); + + # dottime support for notmuch + notmuch = super.notmuch.overrideAttrs (old: { + passthru = old.passthru // { + patches = old.patches ++ [ ./patches/notmuch-dottime.patch ]; + }; + }); + + # nix-serve does not work with nix 2.4 + # https://github.com/edolstra/nix-serve/issues/28 + nix-serve = super.nix-serve.override { nix = self.nix_2_3; }; + + # Avoid builds of mkShell derivations in CI. + mkShell = super.lib.makeOverridable (args: (super.mkShell args).overrideAttrs (_: { + passthru = { + meta.ci.skip = true; + }; + })); + + crate2nix = super.rustPlatform.buildRustPackage rec { + pname = "crate2nix"; + version = "0.13.0"; + + src = super.fetchFromGitHub { + owner = "nix-community"; + repo = "crate2nix"; + rev = "ceb06eb7e76afb9e01a5f069aae136f97df72730"; + hash = "sha256-JTMe8GViCQt51WUiaaoIPmWtwEeeYrl6pBxo2DNuKig="; + }; + + patches = [ ./patches/crate2nix-run-tests-in-build-source.patch ]; + + sourceRoot = "${src.name}/crate2nix"; + + cargoHash = "sha256-dhlSXY1CJE+JJt+6Y7W1MVMz36nwr6ny543py1TcjyY="; + + nativeBuildInputs = [ super.makeWrapper ]; + + # Tests use nix(1), which tries (and fails) to set up /nix/var inside the + # sandbox + doCheck = false; + + postFixup = '' + wrapProgram $out/bin/crate2nix \ + --suffix PATH ":" ${lib.makeBinPath (with self; [ cargo nix_latest nix-prefetch-git ])} + + rm -rf $out/lib $out/bin/crate2nix.d + mkdir -p \ + $out/share/bash-completion/completions \ + $out/share/zsh/vendor-completions + $out/bin/crate2nix completions -s 'bash' -o $out/share/bash-completion/completions + $out/bin/crate2nix completions -s 'zsh' -o $out/share/zsh/vendor-completions + ''; + }; + + evans = super.evans.overrideAttrs (old: { + patches = old.patches or [ ] ++ [ + # add support for unix domain sockets + # https://github.com/ktr0731/evans/pull/680 + ./patches/evans-add-support-for-unix-domain-sockets.patch + ]; + }); + + # Package gerrit-queue, which is not in nixpkgs yet + gerrit-queue = super.buildGoModule { + pname = "gerrit-queue"; + version = "unstable-2023-10-20"; + vendorHash = "sha256-+Ig4D46NphzpWKXO23Haea9EqVtpda8v9zLPJkbe3bQ="; + src = super.fetchFromGitHub { + owner = "flokli"; + repo = "gerrit-queue"; + rev = "0186dbde15c9b11dc17b422feb74c842f6fa605a"; + hash = "sha256-zXB5vre/Vr7UOyeMnf2RCtMKm+v5RENH7kGPr/2o7mI="; + }; + + meta = with lib; { + description = "Gerrit submit bot"; + homepage = "https://github.com/tweag/gerrit-queue"; + license = licenses.asl20; + }; + }; + + # OpenVPN + TPM2 is broken on versions of this package somewhere + # after 1.8.0, but it is a critical dependency for tazjin. For this + # reason it is vendored from a specific nixpkgs commit. + tpm2-pkcs11 = self.callPackage ./patches/tpm2-pkcs11.nix { }; +} diff --git a/third_party/prometheus-fail2ban-exporter/default.nix b/third_party/prometheus-fail2ban-exporter/default.nix new file mode 100644 index 0000000000..42ba0a14db --- /dev/null +++ b/third_party/prometheus-fail2ban-exporter/default.nix @@ -0,0 +1,18 @@ +{ pkgs, ... }: + +let + script = pkgs.fetchurl { + url = "https://raw.githubusercontent.com/jangrewe/prometheus-fail2ban-exporter/11066950b47bb2dbef96ea8544f76e46ed829e81/fail2ban-exporter.py"; + sha256 = "049lsvw1nj65bbvp8ygyz3743ayzdawrbjixaxmpm03qbrcfmwc4"; + }; + + python = pkgs.python3.withPackages (p: [ + p.prometheus-client + ]); + +in +pkgs.writeShellScriptBin "prometheus-fail2ban-exporter" '' + set -eo pipefail + + exec "${python}/bin/python" "${script}" +'' diff --git a/third_party/public-inbox/0001-feat-always-set-the-List-ID-header-even-in-watch.patch b/third_party/public-inbox/0001-feat-always-set-the-List-ID-header-even-in-watch.patch new file mode 100644 index 0000000000..bff2d4c200 --- /dev/null +++ b/third_party/public-inbox/0001-feat-always-set-the-List-ID-header-even-in-watch.patch @@ -0,0 +1,30 @@ +From 1719e904acf19499209b16a8a008f55390a7b5e2 Mon Sep 17 00:00:00 2001 +From: Vincent Ambo <mail@tazj.in> +Date: Sun, 29 Jan 2023 13:36:12 +0300 +Subject: [PATCH] feat: always set the List-ID header even in -watch + +Without bothering to figure out exactly how this code path is usually +triggered, always set a list ID when ingesting new emails in +public-inbox-watch. +--- + lib/PublicInbox/Watch.pm | 4 ++++ + 1 file changed, 4 insertions(+) + +diff --git a/lib/PublicInbox/Watch.pm b/lib/PublicInbox/Watch.pm +index 3f6fe21..147971c 100644 +--- a/lib/PublicInbox/Watch.pm ++++ b/lib/PublicInbox/Watch.pm +@@ -188,6 +188,10 @@ sub _remove_spam { + sub import_eml ($$$) { + my ($self, $ibx, $eml) = @_; + ++ # TVL-specific: always set the list-id header, regardless of ++ # any of the other logic below. ++ PublicInbox::MDA->set_list_headers($eml, $ibx); ++ + # any header match means it's eligible for the inbox: + if (my $watch_hdrs = $ibx->{-watchheaders}) { + my $ok; +-- +2.39.0 + diff --git a/third_party/public-inbox/default.nix b/third_party/public-inbox/default.nix new file mode 100644 index 0000000000..1a4b196f94 --- /dev/null +++ b/third_party/public-inbox/default.nix @@ -0,0 +1,9 @@ +{ pkgs, ... }: + +pkgs.public-inbox.overrideAttrs (old: { + patches = (old.patches or [ ]) ++ [ + ./0001-feat-always-set-the-List-ID-header-even-in-watch.patch + ]; + + doCheck = false; # too slow, and nixpkgs already runs them +}) diff --git a/third_party/python/broadlink/.gitignore b/third_party/python/broadlink/.gitignore new file mode 100644 index 0000000000..0d20b6487c --- /dev/null +++ b/third_party/python/broadlink/.gitignore @@ -0,0 +1 @@ +*.pyc diff --git a/third_party/python/broadlink/LICENSE b/third_party/python/broadlink/LICENSE new file mode 100644 index 0000000000..d8c801656b --- /dev/null +++ b/third_party/python/broadlink/LICENSE @@ -0,0 +1,22 @@ +The MIT License (MIT) + +Copyright (c) 2014 Mike Ryan +Copyright (c) 2016 Matthew Garrett + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/third_party/python/broadlink/README.md b/third_party/python/broadlink/README.md new file mode 100644 index 0000000000..8faba2be75 --- /dev/null +++ b/third_party/python/broadlink/README.md @@ -0,0 +1,112 @@ +Python control for Broadlink RM2, RM3 and RM4 series controllers +=============================================== + +A simple Python API for controlling IR/RF controllers from [Broadlink](http://www.ibroadlink.com/rm/). At present, the following devices are currently supported: + +* RM Pro (referred to as RM2 in the codebase) +* A1 sensor platform devices are supported +* RM3 mini IR blaster +* RM4 and RM4C mini blasters + +There is currently no support for the cloud API. + +Example use +----------- + +Setup a new device on your local wireless network: + +1. Put the device into AP Mode + 1. Long press the reset button until the blue LED is blinking quickly. + 2. Long press again until blue LED is blinking slowly. + 3. Manually connect to the WiFi SSID named BroadlinkProv. +2. Run setup() and provide your ssid, network password (if secured), and set the security mode + 1. Security mode options are (0 = none, 1 = WEP, 2 = WPA1, 3 = WPA2, 4 = WPA1/2) +``` +import broadlink + +broadlink.setup('myssid', 'mynetworkpass', 3) +``` + +Discover available devices on the local network: +``` +import broadlink + +devices = broadlink.discover(timeout=5) +``` + +Obtain the authentication key required for further communication: +``` +devices[0].auth() +``` + +Enter learning mode: +``` +devices[0].enter_learning() +``` + +Sweep RF frequencies: +``` +devices[0].sweep_frequency() +``` + +Cancel sweep RF frequencies: +``` +devices[0].cancel_sweep_frequency() +``` +Check whether a frequency has been found: +``` +found = devices[0].check_frequency() +``` +(This will return True if the RM has locked onto a frequency, False otherwise) + +Attempt to learn an RF packet: +``` +found = devices[0].find_rf_packet() +``` +(This will return True if a packet has been found, False otherwise) + +Obtain an IR or RF packet while in learning mode: +``` +ir_packet = devices[0].check_data() +``` +(This will return None if the device does not have a packet to return) + +Send an IR or RF packet: +``` +devices[0].send_data(ir_packet) +``` + +Obtain temperature data from an RM2: +``` +devices[0].check_temperature() +``` + +Obtain sensor data from an A1: +``` +data = devices[0].check_sensors() +``` + +Set power state on a SmartPlug SP2/SP3: +``` +devices[0].set_power(True) +``` + +Check power state on a SmartPlug: +``` +state = devices[0].check_power() +``` + +Check energy consumption on a SmartPlug: +``` +state = devices[0].get_energy() +``` + +Set power state for S1 on a SmartPowerStrip MP1: +``` +devices[0].set_power(1, True) +``` + +Check power state on a SmartPowerStrip: +``` +state = devices[0].check_power() +``` diff --git a/third_party/python/broadlink/broadlink/__init__.py b/third_party/python/broadlink/broadlink/__init__.py new file mode 100644 index 0000000000..0c70c4beae --- /dev/null +++ b/third_party/python/broadlink/broadlink/__init__.py @@ -0,0 +1,1118 @@ +#!/usr/bin/python + +import codecs +import json +import random +import socket +import struct +import threading +import time +from datetime import datetime + +from cryptography.hazmat.backends import default_backend +from cryptography.hazmat.primitives.ciphers import Cipher, algorithms, modes + + +def gendevice(devtype, host, mac, name=None, cloud=None): + devices = { + sp1: [0], + sp2: [0x2711, # SP2 + 0x2719, 0x7919, 0x271a, 0x791a, # Honeywell SP2 + 0x2720, # SPMini + 0x753e, # SP3 + 0x7D00, # OEM branded SP3 + 0x947a, 0x9479, # SP3S + 0x2728, # SPMini2 + 0x2733, 0x273e, # OEM branded SPMini + 0x7530, 0x7546, 0x7918, # OEM branded SPMini2 + 0x7D0D, # TMall OEM SPMini3 + 0x2736 # SPMiniPlus + ], + rm: [0x2712, # RM2 + 0x2737, # RM Mini + 0x273d, # RM Pro Phicomm + 0x2783, # RM2 Home Plus + 0x277c, # RM2 Home Plus GDT + 0x272a, # RM2 Pro Plus + 0x2787, # RM2 Pro Plus2 + 0x279d, # RM2 Pro Plus3 + 0x27a9, # RM2 Pro Plus_300 + 0x278b, # RM2 Pro Plus BL + 0x2797, # RM2 Pro Plus HYC + 0x27a1, # RM2 Pro Plus R1 + 0x27a6, # RM2 Pro PP + 0x278f, # RM Mini Shate + 0x27c2, # RM Mini 3 + 0x27d1, # new RM Mini3 + 0x27de # RM Mini 3 (C) + ], + rm4: [0x51da, # RM4 Mini + 0x5f36, # RM Mini 3 + 0x6026, # RM4 Pro + 0x610e, # RM4 Mini + 0x610f, # RM4c + 0x62bc, # RM4 Mini + 0x62be # RM4c + ], + a1: [0x2714], # A1 + mp1: [0x4EB5, # MP1 + 0x4EF7 # Honyar oem mp1 + ], + hysen: [0x4EAD], # Hysen controller + S1C: [0x2722], # S1 (SmartOne Alarm Kit) + dooya: [0x4E4D], # Dooya DT360E (DOOYA_CURTAIN_V2) + bg1: [0x51E3], # BG Electrical Smart Power Socket + lb1 : [0x60c8] # RGB Smart Bulb + } + + # Look for the class associated to devtype in devices + [device_class] = [dev for dev in devices if devtype in devices[dev]] or [None] + if device_class is None: + return device(host, mac, devtype, name=name, cloud=cloud) + return device_class(host, mac, devtype, name=name, cloud=cloud) + + +def discover(timeout=None, local_ip_address=None, discover_ip_address='255.255.255.255', max_devices=100): + if local_ip_address is None: + local_ip_address = socket.gethostbyname(socket.gethostname()) + if local_ip_address.startswith('127.'): + s = socket.socket(socket.AF_INET, socket.SOCK_DGRAM) + s.connect(('8.8.8.8', 53)) # connecting to a UDP address doesn't send packets + local_ip_address = s.getsockname()[0] + address = local_ip_address.split('.') + cs = socket.socket(socket.AF_INET, socket.SOCK_DGRAM) + cs.setsockopt(socket.SOL_SOCKET, socket.SO_REUSEADDR, 1) + cs.setsockopt(socket.SOL_SOCKET, socket.SO_BROADCAST, 1) + cs.bind((local_ip_address, 0)) + port = cs.getsockname()[1] + starttime = time.time() + + devices = [] + + timezone = int(time.timezone / -3600) + packet = bytearray(0x30) + + year = datetime.now().year + + if timezone < 0: + packet[0x08] = 0xff + timezone - 1 + packet[0x09] = 0xff + packet[0x0a] = 0xff + packet[0x0b] = 0xff + else: + packet[0x08] = timezone + packet[0x09] = 0 + packet[0x0a] = 0 + packet[0x0b] = 0 + packet[0x0c] = year & 0xff + packet[0x0d] = year >> 8 + packet[0x0e] = datetime.now().minute + packet[0x0f] = datetime.now().hour + subyear = str(year)[2:] + packet[0x10] = int(subyear) + packet[0x11] = datetime.now().isoweekday() + packet[0x12] = datetime.now().day + packet[0x13] = datetime.now().month + packet[0x18] = int(address[0]) + packet[0x19] = int(address[1]) + packet[0x1a] = int(address[2]) + packet[0x1b] = int(address[3]) + packet[0x1c] = port & 0xff + packet[0x1d] = port >> 8 + packet[0x26] = 6 + + checksum = 0xbeaf + for b in packet: + checksum = (checksum + b) & 0xffff + + packet[0x20] = checksum & 0xff + packet[0x21] = checksum >> 8 + + cs.sendto(packet, (discover_ip_address, 80)) + if timeout is None: + response = cs.recvfrom(1024) + responsepacket = bytearray(response[0]) + host = response[1] + devtype = responsepacket[0x34] | responsepacket[0x35] << 8 + mac = responsepacket[0x3a:0x40] + name = responsepacket[0x40:].split(b'\x00')[0].decode('utf-8') + cloud = bool(responsepacket[-1]) + device = gendevice(devtype, host, mac, name=name, cloud=cloud) + return device + + while ((time.time() - starttime) < timeout) and (len(devices) < max_devices): + cs.settimeout(timeout - (time.time() - starttime)) + try: + response = cs.recvfrom(1024) + except socket.timeout: + return devices + responsepacket = bytearray(response[0]) + host = response[1] + devtype = responsepacket[0x34] | responsepacket[0x35] << 8 + mac = responsepacket[0x3a:0x40] + name = responsepacket[0x40:].split(b'\x00')[0].decode('utf-8') + cloud = bool(responsepacket[-1]) + device = gendevice(devtype, host, mac, name=name, cloud=cloud) + devices.append(device) + return devices + + +class device: + def __init__(self, host, mac, devtype, timeout=10, name=None, cloud=None): + self.host = host + self.mac = mac.encode() if isinstance(mac, str) else mac + self.devtype = devtype if devtype is not None else 0x272a + self.name = name + self.cloud = cloud + self.timeout = timeout + self.count = random.randrange(0xffff) + self.iv = bytearray( + [0x56, 0x2e, 0x17, 0x99, 0x6d, 0x09, 0x3d, 0x28, 0xdd, 0xb3, 0xba, 0x69, 0x5a, 0x2e, 0x6f, 0x58]) + self.id = bytearray([0, 0, 0, 0]) + self.cs = socket.socket(socket.AF_INET, socket.SOCK_DGRAM) + self.cs.setsockopt(socket.SOL_SOCKET, socket.SO_REUSEADDR, 1) + self.cs.setsockopt(socket.SOL_SOCKET, socket.SO_BROADCAST, 1) + self.cs.bind(('', 0)) + self.type = "Unknown" + self.lock = threading.Lock() + + self.aes = None + key = bytearray( + [0x09, 0x76, 0x28, 0x34, 0x3f, 0xe9, 0x9e, 0x23, 0x76, 0x5c, 0x15, 0x13, 0xac, 0xcf, 0x8b, 0x02]) + self.update_aes(key) + + def update_aes(self, key): + self.aes = Cipher(algorithms.AES(key), modes.CBC(self.iv), + backend=default_backend()) + + def encrypt(self, payload): + encryptor = self.aes.encryptor() + return encryptor.update(payload) + encryptor.finalize() + + def decrypt(self, payload): + decryptor = self.aes.decryptor() + return decryptor.update(payload) + decryptor.finalize() + + def auth(self): + payload = bytearray(0x50) + payload[0x04] = 0x31 + payload[0x05] = 0x31 + payload[0x06] = 0x31 + payload[0x07] = 0x31 + payload[0x08] = 0x31 + payload[0x09] = 0x31 + payload[0x0a] = 0x31 + payload[0x0b] = 0x31 + payload[0x0c] = 0x31 + payload[0x0d] = 0x31 + payload[0x0e] = 0x31 + payload[0x0f] = 0x31 + payload[0x10] = 0x31 + payload[0x11] = 0x31 + payload[0x12] = 0x31 + payload[0x1e] = 0x01 + payload[0x2d] = 0x01 + payload[0x30] = ord('T') + payload[0x31] = ord('e') + payload[0x32] = ord('s') + payload[0x33] = ord('t') + payload[0x34] = ord(' ') + payload[0x35] = ord(' ') + payload[0x36] = ord('1') + + response = self.send_packet(0x65, payload) + + if any(response[0x22:0x24]): + return False + + payload = self.decrypt(response[0x38:]) + + key = payload[0x04:0x14] + if len(key) % 16 != 0: + return False + + self.id = payload[0x00:0x04] + self.update_aes(key) + + return True + + def get_type(self): + return self.type + + def send_packet(self, command, payload): + self.count = (self.count + 1) & 0xffff + packet = bytearray(0x38) + packet[0x00] = 0x5a + packet[0x01] = 0xa5 + packet[0x02] = 0xaa + packet[0x03] = 0x55 + packet[0x04] = 0x5a + packet[0x05] = 0xa5 + packet[0x06] = 0xaa + packet[0x07] = 0x55 + packet[0x24] = self.devtype & 0xff + packet[0x25] = self.devtype >> 8 + packet[0x26] = command + packet[0x28] = self.count & 0xff + packet[0x29] = self.count >> 8 + packet[0x2a] = self.mac[0] + packet[0x2b] = self.mac[1] + packet[0x2c] = self.mac[2] + packet[0x2d] = self.mac[3] + packet[0x2e] = self.mac[4] + packet[0x2f] = self.mac[5] + packet[0x30] = self.id[0] + packet[0x31] = self.id[1] + packet[0x32] = self.id[2] + packet[0x33] = self.id[3] + + # pad the payload for AES encryption + if payload: + payload += bytearray((16 - len(payload)) % 16) + + checksum = 0xbeaf + for b in payload: + checksum = (checksum + b) & 0xffff + + packet[0x34] = checksum & 0xff + packet[0x35] = checksum >> 8 + + payload = self.encrypt(payload) + for i in range(len(payload)): + packet.append(payload[i]) + + checksum = 0xbeaf + for b in packet: + checksum = (checksum + b) & 0xffff + + packet[0x20] = checksum & 0xff + packet[0x21] = checksum >> 8 + + start_time = time.time() + with self.lock: + while True: + try: + self.cs.sendto(packet, self.host) + self.cs.settimeout(1) + response = self.cs.recvfrom(2048) + break + except socket.timeout: + if (time.time() - start_time) > self.timeout: + raise + return bytearray(response[0]) + + +class mp1(device): + def __init__(self, *args, **kwargs): + device.__init__(self, *args, **kwargs) + self.type = "MP1" + + def set_power_mask(self, sid_mask, state): + """Sets the power state of the smart power strip.""" + + packet = bytearray(16) + packet[0x00] = 0x0d + packet[0x02] = 0xa5 + packet[0x03] = 0xa5 + packet[0x04] = 0x5a + packet[0x05] = 0x5a + packet[0x06] = 0xb2 + ((sid_mask << 1) if state else sid_mask) + packet[0x07] = 0xc0 + packet[0x08] = 0x02 + packet[0x0a] = 0x03 + packet[0x0d] = sid_mask + packet[0x0e] = sid_mask if state else 0 + + self.send_packet(0x6a, packet) + + def set_power(self, sid, state): + """Sets the power state of the smart power strip.""" + sid_mask = 0x01 << (sid - 1) + return self.set_power_mask(sid_mask, state) + + def check_power_raw(self): + """Returns the power state of the smart power strip in raw format.""" + packet = bytearray(16) + packet[0x00] = 0x0a + packet[0x02] = 0xa5 + packet[0x03] = 0xa5 + packet[0x04] = 0x5a + packet[0x05] = 0x5a + packet[0x06] = 0xae + packet[0x07] = 0xc0 + packet[0x08] = 0x01 + + response = self.send_packet(0x6a, packet) + err = response[0x22] | (response[0x23] << 8) + if err != 0: + return None + payload = self.decrypt(bytes(response[0x38:])) + if isinstance(payload[0x4], int): + state = payload[0x0e] + else: + state = ord(payload[0x0e]) + return state + + def check_power(self): + """Returns the power state of the smart power strip.""" + state = self.check_power_raw() + if state is None: + return {'s1': None, 's2': None, 's3': None, 's4': None} + data = {} + data['s1'] = bool(state & 0x01) + data['s2'] = bool(state & 0x02) + data['s3'] = bool(state & 0x04) + data['s4'] = bool(state & 0x08) + return data + + +class bg1(device): + def __init__(self, *args, **kwargs): + device.__init__(self, *args, **kwargs) + self.type = "BG1" + + def get_state(self): + """Get state of device. + + Returns: + dict: Dictionary of current state + eg. `{"pwr":1,"pwr1":1,"pwr2":0,"maxworktime":60,"maxworktime1":60,"maxworktime2":0,"idcbrightness":50}`""" + packet = self._encode(1, b'{}') + response = self.send_packet(0x6a, packet) + return self._decode(response) + + def set_state(self, pwr=None, pwr1=None, pwr2=None, maxworktime=None, maxworktime1=None, maxworktime2=None, idcbrightness=None): + data = {} + if pwr is not None: + data['pwr'] = int(bool(pwr)) + if pwr1 is not None: + data['pwr1'] = int(bool(pwr1)) + if pwr2 is not None: + data['pwr2'] = int(bool(pwr2)) + if maxworktime is not None: + data['maxworktime'] = maxworktime + if maxworktime1 is not None: + data['maxworktime1'] = maxworktime1 + if maxworktime2 is not None: + data['maxworktime2'] = maxworktime2 + if idcbrightness is not None: + data['idcbrightness'] = idcbrightness + js = json.dumps(data).encode('utf8') + packet = self._encode(2, js) + response = self.send_packet(0x6a, packet) + return self._decode(response) + + def _encode(self, flag, js): + # packet format is: + # 0x00-0x01 length + # 0x02-0x05 header + # 0x06-0x07 00 + # 0x08 flag (1 for read or 2 write?) + # 0x09 unknown (0xb) + # 0x0a-0x0d length of json + # 0x0e- json data + packet = bytearray(14) + length = 4 + 2 + 2 + 4 + len(js) + struct.pack_into('<HHHHBBI', packet, 0, length, 0xa5a5, 0x5a5a, 0x0000, flag, 0x0b, len(js)) + for i in range(len(js)): + packet.append(js[i]) + + checksum = 0xc0ad + for b in packet[0x08:]: + checksum = (checksum + b) & 0xffff + + packet[0x06] = checksum & 0xff + packet[0x07] = checksum >> 8 + + return packet + + def _decode(self, response): + err = response[0x22] | (response[0x23] << 8) + if err != 0: + return None + + payload = self.decrypt(bytes(response[0x38:])) + js_len = struct.unpack_from('<I', payload, 0x0a)[0] + state = json.loads(payload[0x0e:0x0e+js_len]) + return state + +class sp1(device): + def __init__(self, *args, **kwargs): + device.__init__(self, *args, **kwargs) + self.type = "SP1" + + def set_power(self, state): + packet = bytearray(4) + packet[0] = state + self.send_packet(0x66, packet) + + +class sp2(device): + def __init__(self, *args, **kwargs): + device.__init__(self, *args, **kwargs) + self.type = "SP2" + + def set_power(self, state): + """Sets the power state of the smart plug.""" + packet = bytearray(16) + packet[0] = 2 + if self.check_nightlight(): + packet[4] = 3 if state else 2 + else: + packet[4] = 1 if state else 0 + self.send_packet(0x6a, packet) + + def set_nightlight(self, state): + """Sets the night light state of the smart plug""" + packet = bytearray(16) + packet[0] = 2 + if self.check_power(): + packet[4] = 3 if state else 1 + else: + packet[4] = 2 if state else 0 + self.send_packet(0x6a, packet) + + def check_power(self): + """Returns the power state of the smart plug.""" + packet = bytearray(16) + packet[0] = 1 + response = self.send_packet(0x6a, packet) + err = response[0x22] | (response[0x23] << 8) + if err != 0: + return None + payload = self.decrypt(bytes(response[0x38:])) + if isinstance(payload[0x4], int): + return bool(payload[0x4] == 1 or payload[0x4] == 3 or payload[0x4] == 0xFD) + return bool(ord(payload[0x4]) == 1 or ord(payload[0x4]) == 3 or ord(payload[0x4]) == 0xFD) + + def check_nightlight(self): + """Returns the power state of the smart plug.""" + packet = bytearray(16) + packet[0] = 1 + response = self.send_packet(0x6a, packet) + err = response[0x22] | (response[0x23] << 8) + if err != 0: + return None + payload = self.decrypt(bytes(response[0x38:])) + if isinstance(payload[0x4], int): + return bool(payload[0x4] == 2 or payload[0x4] == 3 or payload[0x4] == 0xFF) + return bool(ord(payload[0x4]) == 2 or ord(payload[0x4]) == 3 or ord(payload[0x4]) == 0xFF) + + def get_energy(self): + packet = bytearray([8, 0, 254, 1, 5, 1, 0, 0, 0, 45]) + response = self.send_packet(0x6a, packet) + err = response[0x22] | (response[0x23] << 8) + if err != 0: + return None + payload = self.decrypt(bytes(response[0x38:])) + if isinstance(payload[0x7], int): + energy = int(hex(payload[0x07] * 256 + payload[0x06])[2:]) + int(hex(payload[0x05])[2:]) / 100.0 + else: + energy = int(hex(ord(payload[0x07]) * 256 + ord(payload[0x06]))[2:]) + int( + hex(ord(payload[0x05]))[2:]) / 100.0 + return energy + + +class a1(device): + def __init__(self, *args, **kwargs): + device.__init__(self, *args, **kwargs) + self.type = "A1" + + def check_sensors(self): + packet = bytearray(16) + packet[0] = 1 + response = self.send_packet(0x6a, packet) + err = response[0x22] | (response[0x23] << 8) + if err != 0: + return None + data = {} + payload = self.decrypt(bytes(response[0x38:])) + if isinstance(payload[0x4], int): + data['temperature'] = (payload[0x4] * 10 + payload[0x5]) / 10.0 + data['humidity'] = (payload[0x6] * 10 + payload[0x7]) / 10.0 + light = payload[0x8] + air_quality = payload[0x0a] + noise = payload[0xc] + else: + data['temperature'] = (ord(payload[0x4]) * 10 + ord(payload[0x5])) / 10.0 + data['humidity'] = (ord(payload[0x6]) * 10 + ord(payload[0x7])) / 10.0 + light = ord(payload[0x8]) + air_quality = ord(payload[0x0a]) + noise = ord(payload[0xc]) + if light == 0: + data['light'] = 'dark' + elif light == 1: + data['light'] = 'dim' + elif light == 2: + data['light'] = 'normal' + elif light == 3: + data['light'] = 'bright' + else: + data['light'] = 'unknown' + if air_quality == 0: + data['air_quality'] = 'excellent' + elif air_quality == 1: + data['air_quality'] = 'good' + elif air_quality == 2: + data['air_quality'] = 'normal' + elif air_quality == 3: + data['air_quality'] = 'bad' + else: + data['air_quality'] = 'unknown' + if noise == 0: + data['noise'] = 'quiet' + elif noise == 1: + data['noise'] = 'normal' + elif noise == 2: + data['noise'] = 'noisy' + else: + data['noise'] = 'unknown' + return data + + def check_sensors_raw(self): + packet = bytearray(16) + packet[0] = 1 + response = self.send_packet(0x6a, packet) + err = response[0x22] | (response[0x23] << 8) + if err != 0: + return None + data = {} + payload = self.decrypt(bytes(response[0x38:])) + if isinstance(payload[0x4], int): + data['temperature'] = (payload[0x4] * 10 + payload[0x5]) / 10.0 + data['humidity'] = (payload[0x6] * 10 + payload[0x7]) / 10.0 + data['light'] = payload[0x8] + data['air_quality'] = payload[0x0a] + data['noise'] = payload[0xc] + else: + data['temperature'] = (ord(payload[0x4]) * 10 + ord(payload[0x5])) / 10.0 + data['humidity'] = (ord(payload[0x6]) * 10 + ord(payload[0x7])) / 10.0 + data['light'] = ord(payload[0x8]) + data['air_quality'] = ord(payload[0x0a]) + data['noise'] = ord(payload[0xc]) + return data + + +class rm(device): + def __init__(self, *args, **kwargs): + device.__init__(self, *args, **kwargs) + self.type = "RM2" + self._request_header = bytes() + self._code_sending_header = bytes() + + def check_data(self): + packet = bytearray(self._request_header) + packet.append(0x04) + response = self.send_packet(0x6a, packet) + err = response[0x22] | (response[0x23] << 8) + if err != 0: + return None + payload = self.decrypt(bytes(response[0x38:])) + return payload[len(self._request_header) + 4:] + + def send_data(self, data): + packet = bytearray(self._code_sending_header) + packet += bytes([0x02, 0x00, 0x00, 0x00]) + packet += data + self.send_packet(0x6a, packet) + + def enter_learning(self): + packet = bytearray(self._request_header) + packet.append(0x03) + self.send_packet(0x6a, packet) + + def sweep_frequency(self): + packet = bytearray(self._request_header) + packet.append(0x19) + self.send_packet(0x6a, packet) + + def cancel_sweep_frequency(self): + packet = bytearray(self._request_header) + packet.append(0x1e) + self.send_packet(0x6a, packet) + + def check_frequency(self): + packet = bytearray(self._request_header) + packet.append(0x1a) + response = self.send_packet(0x6a, packet) + err = response[0x22] | (response[0x23] << 8) + if err != 0: + return False + payload = self.decrypt(bytes(response[0x38:])) + if payload[len(self._request_header) + 4] == 1: + return True + return False + + def find_rf_packet(self): + packet = bytearray(self._request_header) + packet.append(0x1b) + response = self.send_packet(0x6a, packet) + err = response[0x22] | (response[0x23] << 8) + if err != 0: + return False + payload = self.decrypt(bytes(response[0x38:])) + if payload[len(self._request_header) + 4] == 1: + return True + return False + + def _read_sensor(self, type, offset, divider): + packet = bytearray(self._request_header) + packet.append(type) + response = self.send_packet(0x6a, packet) + err = response[0x22] | (response[0x23] << 8) + if err != 0: + return False + payload = self.decrypt(bytes(response[0x38:])) + value_pos = len(self._request_header) + offset + if isinstance(payload[value_pos], int): + value = (payload[value_pos] + payload[value_pos+1] / divider) + else: + value = (ord(payload[value_pos]) + ord(payload[value_pos+1]) / divider) + return value + + def check_temperature(self): + return self._read_sensor( 0x01, 4, 10.0 ) + +class rm4(rm): + def __init__(self, *args, **kwargs): + device.__init__(self, *args, **kwargs) + self.type = "RM4" + self._request_header = b'\x04\x00' + self._code_sending_header = b'\xd0\x00' + + def check_temperature(self): + return self._read_sensor( 0x24, 4, 100.0 ) + + def check_humidity(self): + return self._read_sensor( 0x24, 6, 100.0 ) + + def check_sensors(self): + return { + 'temperature': self.check_temperature(), + 'humidity': self.check_humidity() + } + +# For legacy compatibility - don't use this +class rm2(rm): + def __init__(self): + device.__init__(self, None, None, None) + + def discover(self): + dev = discover() + self.host = dev.host + self.mac = dev.mac + + +class hysen(device): + def __init__(self, *args, **kwargs): + device.__init__(self, *args, **kwargs) + self.type = "Hysen heating controller" + + # Send a request + # input_payload should be a bytearray, usually 6 bytes, e.g. bytearray([0x01,0x06,0x00,0x02,0x10,0x00]) + # Returns decrypted payload + # New behaviour: raises a ValueError if the device response indicates an error or CRC check fails + # The function prepends length (2 bytes) and appends CRC + + def calculate_crc16(self, input_data): + from ctypes import c_ushort + crc16_tab = [] + crc16_constant = 0xA001 + + for i in range(0, 256): + crc = c_ushort(i).value + for j in range(0, 8): + if (crc & 0x0001): + crc = c_ushort(crc >> 1).value ^ crc16_constant + else: + crc = c_ushort(crc >> 1).value + crc16_tab.append(hex(crc)) + + try: + is_string = isinstance(input_data, str) + is_bytes = isinstance(input_data, bytes) + + if not is_string and not is_bytes: + raise Exception("Please provide a string or a byte sequence " + "as argument for calculation.") + + crcValue = 0xffff + + for c in input_data: + d = ord(c) if is_string else c + tmp = crcValue ^ d + rotated = c_ushort(crcValue >> 8).value + crcValue = rotated ^ int(crc16_tab[(tmp & 0x00ff)], 0) + + return crcValue + except Exception as e: + print("EXCEPTION(calculate): {}".format(e)) + + def send_request(self, input_payload): + + crc = self.calculate_crc16(bytes(input_payload)) + + # first byte is length, +2 for CRC16 + request_payload = bytearray([len(input_payload) + 2, 0x00]) + request_payload.extend(input_payload) + + # append CRC + request_payload.append(crc & 0xFF) + request_payload.append((crc >> 8) & 0xFF) + + # send to device + response = self.send_packet(0x6a, request_payload) + + # check for error + err = response[0x22] | (response[0x23] << 8) + if err: + raise ValueError('broadlink_response_error', err) + + response_payload = bytearray(self.decrypt(bytes(response[0x38:]))) + + # experimental check on CRC in response (first 2 bytes are len, and trailing bytes are crc) + response_payload_len = response_payload[0] + if response_payload_len + 2 > len(response_payload): + raise ValueError('hysen_response_error', 'first byte of response is not length') + crc = self.calculate_crc16(bytes(response_payload[2:response_payload_len])) + if (response_payload[response_payload_len] == crc & 0xFF) and ( + response_payload[response_payload_len + 1] == (crc >> 8) & 0xFF): + return response_payload[2:response_payload_len] + raise ValueError('hysen_response_error', 'CRC check on response failed') + + # Get current room temperature in degrees celsius + def get_temp(self): + payload = self.send_request(bytearray([0x01, 0x03, 0x00, 0x00, 0x00, 0x08])) + return payload[0x05] / 2.0 + + # Get current external temperature in degrees celsius + def get_external_temp(self): + payload = self.send_request(bytearray([0x01, 0x03, 0x00, 0x00, 0x00, 0x08])) + return payload[18] / 2.0 + + # Get full status (including timer schedule) + def get_full_status(self): + payload = self.send_request(bytearray([0x01, 0x03, 0x00, 0x00, 0x00, 0x16])) + data = {} + data['remote_lock'] = payload[3] & 1 + data['power'] = payload[4] & 1 + data['active'] = (payload[4] >> 4) & 1 + data['temp_manual'] = (payload[4] >> 6) & 1 + data['room_temp'] = (payload[5] & 255) / 2.0 + data['thermostat_temp'] = (payload[6] & 255) / 2.0 + data['auto_mode'] = payload[7] & 15 + data['loop_mode'] = (payload[7] >> 4) & 15 + data['sensor'] = payload[8] + data['osv'] = payload[9] + data['dif'] = payload[10] + data['svh'] = payload[11] + data['svl'] = payload[12] + data['room_temp_adj'] = ((payload[13] << 8) + payload[14]) / 2.0 + if data['room_temp_adj'] > 32767: + data['room_temp_adj'] = 32767 - data['room_temp_adj'] + data['fre'] = payload[15] + data['poweron'] = payload[16] + data['unknown'] = payload[17] + data['external_temp'] = (payload[18] & 255) / 2.0 + data['hour'] = payload[19] + data['min'] = payload[20] + data['sec'] = payload[21] + data['dayofweek'] = payload[22] + + weekday = [] + for i in range(0, 6): + weekday.append( + {'start_hour': payload[2 * i + 23], 'start_minute': payload[2 * i + 24], 'temp': payload[i + 39] / 2.0}) + + data['weekday'] = weekday + weekend = [] + for i in range(6, 8): + weekend.append( + {'start_hour': payload[2 * i + 23], 'start_minute': payload[2 * i + 24], 'temp': payload[i + 39] / 2.0}) + + data['weekend'] = weekend + return data + + # Change controller mode + # auto_mode = 1 for auto (scheduled/timed) mode, 0 for manual mode. + # Manual mode will activate last used temperature. + # In typical usage call set_temp to activate manual control and set temp. + # loop_mode refers to index in [ "12345,67", "123456,7", "1234567" ] + # E.g. loop_mode = 0 ("12345,67") means Saturday and Sunday follow the "weekend" schedule + # loop_mode = 2 ("1234567") means every day (including Saturday and Sunday) follows the "weekday" schedule + # The sensor command is currently experimental + def set_mode(self, auto_mode, loop_mode, sensor=0): + mode_byte = ((loop_mode + 1) << 4) + auto_mode + self.send_request(bytearray([0x01, 0x06, 0x00, 0x02, mode_byte, sensor])) + + # Advanced settings + # Sensor mode (SEN) sensor = 0 for internal sensor, 1 for external sensor, + # 2 for internal control temperature, external limit temperature. Factory default: 0. + # Set temperature range for external sensor (OSV) osv = 5..99. Factory default: 42C + # Deadzone for floor temprature (dIF) dif = 1..9. Factory default: 2C + # Upper temperature limit for internal sensor (SVH) svh = 5..99. Factory default: 35C + # Lower temperature limit for internal sensor (SVL) svl = 5..99. Factory default: 5C + # Actual temperature calibration (AdJ) adj = -0.5. Prescision 0.1C + # Anti-freezing function (FrE) fre = 0 for anti-freezing function shut down, + # 1 for anti-freezing function open. Factory default: 0 + # Power on memory (POn) poweron = 0 for power on memory off, 1 for power on memory on. Factory default: 0 + def set_advanced(self, loop_mode, sensor, osv, dif, svh, svl, adj, fre, poweron): + input_payload = bytearray([0x01, 0x10, 0x00, 0x02, 0x00, 0x05, 0x0a, loop_mode, sensor, osv, dif, svh, svl, + (int(adj * 2) >> 8 & 0xff), (int(adj * 2) & 0xff), fre, poweron]) + self.send_request(input_payload) + + # For backwards compatibility only. Prefer calling set_mode directly. + # Note this function invokes loop_mode=0 and sensor=0. + def switch_to_auto(self): + self.set_mode(auto_mode=1, loop_mode=0) + + def switch_to_manual(self): + self.set_mode(auto_mode=0, loop_mode=0) + + # Set temperature for manual mode (also activates manual mode if currently in automatic) + def set_temp(self, temp): + self.send_request(bytearray([0x01, 0x06, 0x00, 0x01, 0x00, int(temp * 2)])) + + # Set device on(1) or off(0), does not deactivate Wifi connectivity. + # Remote lock disables control by buttons on thermostat. + def set_power(self, power=1, remote_lock=0): + self.send_request(bytearray([0x01, 0x06, 0x00, 0x00, remote_lock, power])) + + # set time on device + # n.b. day=1 is Monday, ..., day=7 is Sunday + def set_time(self, hour, minute, second, day): + self.send_request(bytearray([0x01, 0x10, 0x00, 0x08, 0x00, 0x02, 0x04, hour, minute, second, day])) + + # Set timer schedule + # Format is the same as you get from get_full_status. + # weekday is a list (ordered) of 6 dicts like: + # {'start_hour':17, 'start_minute':30, 'temp': 22 } + # Each one specifies the thermostat temp that will become effective at start_hour:start_minute + # weekend is similar but only has 2 (e.g. switch on in morning and off in afternoon) + def set_schedule(self, weekday, weekend): + # Begin with some magic values ... + input_payload = bytearray([0x01, 0x10, 0x00, 0x0a, 0x00, 0x0c, 0x18]) + + # Now simply append times/temps + # weekday times + for i in range(0, 6): + input_payload.append(weekday[i]['start_hour']) + input_payload.append(weekday[i]['start_minute']) + + # weekend times + for i in range(0, 2): + input_payload.append(weekend[i]['start_hour']) + input_payload.append(weekend[i]['start_minute']) + + # weekday temperatures + for i in range(0, 6): + input_payload.append(int(weekday[i]['temp'] * 2)) + + # weekend temperatures + for i in range(0, 2): + input_payload.append(int(weekend[i]['temp'] * 2)) + + self.send_request(input_payload) + + +S1C_SENSORS_TYPES = { + 0x31: 'Door Sensor', # 49 as hex + 0x91: 'Key Fob', # 145 as hex, as serial on fob corpse + 0x21: 'Motion Sensor' # 33 as hex +} + + +class S1C(device): + """ + Its VERY VERY VERY DIRTY IMPLEMENTATION of S1C + """ + + def __init__(self, *args, **kwargs): + device.__init__(self, *args, **kwargs) + self.type = 'S1C' + + def get_sensors_status(self): + packet = bytearray(16) + packet[0] = 0x06 # 0x06 - get sensors info, 0x07 - probably add sensors + response = self.send_packet(0x6a, packet) + err = response[0x22] | (response[0x23] << 8) + if err != 0: + return None + + payload = self.decrypt(bytes(response[0x38:])) + if not payload: + return None + count = payload[0x4] + sensors = payload[0x6:] + sensors_a = [bytearray(sensors[i * 83:(i + 1) * 83]) for i in range(len(sensors) // 83)] + + sens_res = [] + for sens in sensors_a: + status = ord(chr(sens[0])) + _name = str(bytes(sens[4:26]).decode()) + _order = ord(chr(sens[1])) + _type = ord(chr(sens[3])) + _serial = bytes(codecs.encode(sens[26:30], "hex")).decode() + + type_str = S1C_SENSORS_TYPES.get(_type, 'Unknown') + + r = { + 'status': status, + 'name': _name.strip('\x00'), + 'type': type_str, + 'order': _order, + 'serial': _serial, + } + if r['serial'] != '00000000': + sens_res.append(r) + result = { + 'count': count, + 'sensors': sens_res + } + return result + + +class dooya(device): + def __init__(self, *args, **kwargs): + device.__init__(self, *args, **kwargs) + self.type = "Dooya DT360E" + + def _send(self, magic1, magic2): + packet = bytearray(16) + packet[0] = 0x09 + packet[2] = 0xbb + packet[3] = magic1 + packet[4] = magic2 + packet[9] = 0xfa + packet[10] = 0x44 + response = self.send_packet(0x6a, packet) + err = response[0x22] | (response[0x23] << 8) + if err != 0: + return None + payload = self.decrypt(bytes(response[0x38:])) + return ord(payload[4]) + + def open(self): + return self._send(0x01, 0x00) + + def close(self): + return self._send(0x02, 0x00) + + def stop(self): + return self._send(0x03, 0x00) + + def get_percentage(self): + return self._send(0x06, 0x5d) + + def set_percentage_and_wait(self, new_percentage): + current = self.get_percentage() + if current > new_percentage: + self.close() + while current is not None and current > new_percentage: + time.sleep(0.2) + current = self.get_percentage() + + elif current < new_percentage: + self.open() + while current is not None and current < new_percentage: + time.sleep(0.2) + current = self.get_percentage() + self.stop() + +class lb1(device): + state_dict = [] + effect_map_dict = { 'lovely color' : 0, + 'flashlight' : 1, + 'lightning' : 2, + 'color fading' : 3, + 'color breathing' : 4, + 'multicolor breathing' : 5, + 'color jumping' : 6, + 'multicolor jumping' : 7 } + + def __init__(self, host, mac, devtype): + device.__init__(self, host, mac, devtype) + self.type = "SmartBulb" + + def send_command(self,command, type = 'set'): + packet = bytearray(16+(int(len(command)/16) + 1)*16) + packet[0x02] = 0xa5 + packet[0x03] = 0xa5 + packet[0x04] = 0x5a + packet[0x05] = 0x5a + packet[0x08] = 0x02 if type == "set" else 0x01 # 0x01 => query, # 0x02 => set + packet[0x09] = 0x0b + packet[0x0a] = len(command) + packet[0x0e:] = map(ord, command) + + checksum = 0xbeaf + for b in packet: + checksum = (checksum + b) & 0xffff + + packet[0x00] = (0x0c + len(command)) & 0xff + packet[0x06] = checksum & 0xff # Checksum 1 position + packet[0x07] = checksum >> 8 # Checksum 2 position + + response = self.send_packet(0x6a, packet) + + err = response[0x36] | (response[0x37] << 8) + if err != 0: + return None + payload = self.decrypt(bytes(response[0x38:])) + + responseLength = int(payload[0x0a]) | (int(payload[0x0b]) << 8) + if responseLength > 0: + self.state_dict = json.loads(payload[0x0e:0x0e+responseLength]) + + def set_json(self, jsonstr): + reconvert = json.loads(jsonstr) + if 'bulb_sceneidx' in reconvert.keys(): + reconvert['bulb_sceneidx'] = self.effect_map_dict.get(reconvert['bulb_sceneidx'], 255) + + self.send_command(json.dumps(reconvert)) + return json.dumps(self.state_dict) + + def set_state(self, state): + cmd = '{"pwr":%d}' % (1 if state == "ON" or state == 1 else 0) + self.send_command(cmd) + + def get_state(self): + cmd = "{}" + self.send_command(cmd) + return self.state_dict + +# Setup a new Broadlink device via AP Mode. Review the README to see how to enter AP Mode. +# Only tested with Broadlink RM3 Mini (Blackbean) +def setup(ssid, password, security_mode): + # Security mode options are (0 - none, 1 = WEP, 2 = WPA1, 3 = WPA2, 4 = WPA1/2) + payload = bytearray(0x88) + payload[0x26] = 0x14 # This seems to always be set to 14 + # Add the SSID to the payload + ssid_start = 68 + ssid_length = 0 + for letter in ssid: + payload[(ssid_start + ssid_length)] = ord(letter) + ssid_length += 1 + # Add the WiFi password to the payload + pass_start = 100 + pass_length = 0 + for letter in password: + payload[(pass_start + pass_length)] = ord(letter) + pass_length += 1 + + payload[0x84] = ssid_length # Character length of SSID + payload[0x85] = pass_length # Character length of password + payload[0x86] = security_mode # Type of encryption (00 - none, 01 = WEP, 02 = WPA1, 03 = WPA2, 04 = WPA1/2) + + checksum = 0xbeaf + for b in payload: + checksum = (checksum + b) & 0xffff + + payload[0x20] = checksum & 0xff # Checksum 1 position + payload[0x21] = checksum >> 8 # Checksum 2 position + + sock = socket.socket(socket.AF_INET, # Internet + socket.SOCK_DGRAM) # UDP + sock.setsockopt(socket.SOL_SOCKET, socket.SO_REUSEADDR, 1) + # sock.setsockopt(socket.SOL_SOCKET, socket.SO_BROADCAST, 1) + sock.sendto(payload, ('192.168.10.1', 80)) diff --git a/third_party/python/broadlink/cli/README.md b/third_party/python/broadlink/cli/README.md new file mode 100644 index 0000000000..7e229e3eb5 --- /dev/null +++ b/third_party/python/broadlink/cli/README.md @@ -0,0 +1,85 @@ +Command line interface for python-broadlink +=========================================== + +This is a command line interface for broadlink python library + +Tested with BroadLink RMPRO / RM2 + + +Requirements +------------ +You should have the broadlink python installed, this can be made in many linux distributions using : +``` +sudo pip install broadlink +``` + +Installation +----------- +Just copy this files + + +Programs +-------- + + +* broadlink_discovery +used to run the discovery in the network +this program withh show the command line parameters to be used with +broadlink_cli to select broadlink device + +* broadlink_cli +used to send commands and query the broadlink device + + +device specification formats +---------------------------- + +Using separate parameters for each information: +``` +broadlink_cli --type 0x2712 --host 1.1.1.1 --mac aaaaaaaaaa --temp +``` + +Using all parameters as a single argument: +``` +broadlink_cli --device "0x2712 1.1.1.1 aaaaaaaaaa" --temp +``` + +Using file with parameters: +``` +broadlink_cli --device @BEDROOM.device --temp +``` +This is prefered as the configuration is stored in file and you can change +just a file to point to a different hardware + +Sample usage +------------ + +Learn commands : +``` +# Learn and save to file +broadlink_cli --device @BEDROOM.device --learnfile LG-TV.power +# LEard and show at console +broadlink_cli --device @BEDROOM.device --learn +``` + + +Send command : +``` +broadlink_cli --device @BEDROOM.device --send @LG-TV.power +broadlink_cli --device @BEDROOM.device --send ....datafromlearncommand... +``` + +Get Temperature : +``` +broadlink_cli --device @BEDROOM.device --temperature +``` + +Get Energy Consumption (For a SmartPlug) : +``` +broadlink_cli --device @BEDROOM.device --energy +``` + +Once joined to the Broadlink provisioning Wi-Fi, configure it with your Wi-Fi details: +``` +broadlink_cli --joinwifi MySSID MyWifiPassword +``` diff --git a/third_party/python/broadlink/cli/broadlink_cli b/third_party/python/broadlink/cli/broadlink_cli new file mode 100755 index 0000000000..5045c5c108 --- /dev/null +++ b/third_party/python/broadlink/cli/broadlink_cli @@ -0,0 +1,239 @@ +#!/usr/bin/env python3 + +import argparse +import base64 +import codecs +import time + +import broadlink + +TICK = 32.84 +IR_TOKEN = 0x26 + + +def auto_int(x): + return int(x, 0) + + +def to_microseconds(bytes): + result = [] + # print bytes[0] # 0x26 = 38for IR + index = 4 + while index < len(bytes): + chunk = bytes[index] + index += 1 + if chunk == 0: + chunk = bytes[index] + chunk = 256 * chunk + bytes[index + 1] + index += 2 + result.append(int(round(chunk * TICK))) + if chunk == 0x0d05: + break + return result + + +def durations_to_broadlink(durations): + result = bytearray() + result.append(IR_TOKEN) + result.append(0) + result.append(len(durations) % 256) + result.append(len(durations) / 256) + for dur in durations: + num = int(round(dur / TICK)) + if num > 255: + result.append(0) + result.append(num / 256) + result.append(num % 256) + return result + + +def format_durations(data): + result = '' + for i in range(0, len(data)): + if len(result) > 0: + result += ' ' + result += ('+' if i % 2 == 0 else '-') + str(data[i]) + return result + + +def parse_durations(str): + result = [] + for s in str.split(): + result.append(abs(int(s))) + return result + + +parser = argparse.ArgumentParser(fromfile_prefix_chars='@') +parser.add_argument("--device", help="device definition as 'type host mac'") +parser.add_argument("--type", type=auto_int, default=0x2712, help="type of device") +parser.add_argument("--host", help="host address") +parser.add_argument("--mac", help="mac address (hex reverse), as used by python-broadlink library") +parser.add_argument("--temperature", action="store_true", help="request temperature from device") +parser.add_argument("--energy", action="store_true", help="request energy consumption from device") +parser.add_argument("--check", action="store_true", help="check current power state") +parser.add_argument("--checknl", action="store_true", help="check current nightlight state") +parser.add_argument("--turnon", action="store_true", help="turn on device") +parser.add_argument("--turnoff", action="store_true", help="turn off device") +parser.add_argument("--turnnlon", action="store_true", help="turn on nightlight on the device") +parser.add_argument("--turnnloff", action="store_true", help="turn off nightlight on the device") +parser.add_argument("--switch", action="store_true", help="switch state from on to off and off to on") +parser.add_argument("--send", action="store_true", help="send command") +parser.add_argument("--sensors", action="store_true", help="check all sensors") +parser.add_argument("--learn", action="store_true", help="learn command") +parser.add_argument("--rfscanlearn", action="store_true", help="rf scan learning") +parser.add_argument("--learnfile", help="save learned command to a specified file") +parser.add_argument("--durations", action="store_true", + help="use durations in micro seconds instead of the Broadlink format") +parser.add_argument("--convert", action="store_true", help="convert input data to durations") +parser.add_argument("--joinwifi", nargs=2, help="Args are SSID PASSPHRASE to configure Broadlink device with"); +parser.add_argument("data", nargs='*', help="Data to send or convert") +args = parser.parse_args() + +if args.device: + values = args.device.split() + type = int(values[0], 0) + host = values[1] + mac = bytearray.fromhex(values[2]) +elif args.mac: + type = args.type + host = args.host + mac = bytearray.fromhex(args.mac) + +if args.host or args.device: + dev = broadlink.gendevice(type, (host, 80), mac) + dev.auth() + +if args.joinwifi: + broadlink.setup(args.joinwifi[0], args.joinwifi[1], 4) + +if args.convert: + data = bytearray.fromhex(''.join(args.data)) + durations = to_microseconds(data) + print(format_durations(durations)) +if args.temperature: + print(dev.check_temperature()) +if args.energy: + print(dev.get_energy()) +if args.sensors: + try: + data = dev.check_sensors() + except: + data = {} + data['temperature'] = dev.check_temperature() + for key in data: + print("{} {}".format(key, data[key])) +if args.send: + data = durations_to_broadlink(parse_durations(' '.join(args.data))) \ + if args.durations else bytearray.fromhex(''.join(args.data)) + dev.send_data(data) +if args.learn or args.learnfile: + dev.enter_learning() + data = None + print("Learning...") + timeout = 30 + while (data is None) and (timeout > 0): + time.sleep(2) + timeout -= 2 + data = dev.check_data() + if data: + learned = format_durations(to_microseconds(bytearray(data))) \ + if args.durations \ + else ''.join(format(x, '02x') for x in bytearray(data)) + if args.learn: + print(learned) + decode_hex = codecs.getdecoder("hex_codec") + print("Base64: " + str(base64.b64encode(decode_hex(learned)[0]))) + if args.learnfile: + print("Saving to {}".format(args.learnfile)) + with open(args.learnfile, "w") as text_file: + text_file.write(learned) + else: + print("No data received...") +if args.check: + if dev.check_power(): + print('* ON *') + else: + print('* OFF *') +if args.checknl: + if dev.check_nightlight(): + print('* ON *') + else: + print('* OFF *') +if args.turnon: + dev.set_power(True) + if dev.check_power(): + print('== Turned * ON * ==') + else: + print('!! Still OFF !!') +if args.turnoff: + dev.set_power(False) + if dev.check_power(): + print('!! Still ON !!') + else: + print('== Turned * OFF * ==') +if args.turnnlon: + dev.set_nightlight(True) + if dev.check_nightlight(): + print('== Turned * ON * ==') + else: + print('!! Still OFF !!') +if args.turnnloff: + dev.set_nightlight(False) + if dev.check_nightlight(): + print('!! Still ON !!') + else: + print('== Turned * OFF * ==') +if args.switch: + if dev.check_power(): + dev.set_power(False) + print('* Switch to OFF *') + else: + dev.set_power(True) + print('* Switch to ON *') +if args.rfscanlearn: + dev.sweep_frequency() + print("Learning RF Frequency, press and hold the button to learn...") + + timeout = 20 + + while (not dev.check_frequency()) and (timeout > 0): + time.sleep(1) + timeout -= 1 + + if timeout <= 0: + print("RF Frequency not found") + dev.cancel_sweep_frequency() + exit(1) + + print("Found RF Frequency - 1 of 2!") + print("You can now let go of the button") + + input("Press enter to continue...") + + print("To complete learning, single press the button you want to learn") + + dev.find_rf_packet() + + data = None + timeout = 20 + + while (data is None) and (timeout > 0): + time.sleep(1) + timeout -= 1 + data = dev.check_data() + + if data: + print("Found RF Frequency - 2 of 2!") + learned = format_durations(to_microseconds(bytearray(data))) \ + if args.durations \ + else ''.join(format(x, '02x') for x in bytearray(data)) + if args.learnfile is None: + print(learned) + decode_hex = codecs.getdecoder("hex_codec") + print("Base64: {}".format(str(base64.b64encode(decode_hex(learned)[0])))) + if args.learnfile is not None: + print("Saving to {}".format(args.learnfile)) + with open(args.learnfile, "w") as text_file: + text_file.write(learned) + else: + print("No data received...") diff --git a/third_party/python/broadlink/cli/broadlink_discovery b/third_party/python/broadlink/cli/broadlink_discovery new file mode 100755 index 0000000000..1c6b80b148 --- /dev/null +++ b/third_party/python/broadlink/cli/broadlink_discovery @@ -0,0 +1,27 @@ +#!/usr/bin/env python + +import argparse + +import broadlink + +parser = argparse.ArgumentParser(fromfile_prefix_chars='@') +parser.add_argument("--timeout", type=int, default=5, help="timeout to wait for receiving discovery responses") +parser.add_argument("--ip", default=None, help="ip address to use in the discovery") +parser.add_argument("--dst-ip", default=None, help="destination ip address to use in the discovery") +args = parser.parse_args() + +print("Discovering...") +devices = broadlink.discover(timeout=args.timeout, local_ip_address=args.ip, discover_ip_address=args.dst_ip) +for device in devices: + if device.auth(): + print("###########################################") + print(device.type) + print("# broadlink_cli --type {} --host {} --mac {}".format(hex(device.devtype), device.host[0], + ''.join(format(x, '02x') for x in device.mac))) + print("Device file data (to be used with --device @filename in broadlink_cli) : ") + print("{} {} {}".format(hex(device.devtype), device.host[0], ''.join(format(x, '02x') for x in device.mac))) + if hasattr(device, 'check_temperature'): + print("temperature = {}".format(device.check_temperature())) + print("") + else: + print("Error authenticating with device : {}".format(device.host)) diff --git a/third_party/python/broadlink/default.nix b/third_party/python/broadlink/default.nix new file mode 100644 index 0000000000..b1dcf30081 --- /dev/null +++ b/third_party/python/broadlink/default.nix @@ -0,0 +1,16 @@ +# Python package for controlling the Broadlink RM Pro Infrared +# controller. +# +# https://github.com/mjg59/python-broadlink +{ pkgs, lib, ... }: + +let + inherit (pkgs) fetchFromGitHub; + inherit (pkgs.python3Packages) buildPythonPackage cryptography; +in +buildPythonPackage (lib.fix (self: { + pname = "python-broadlink"; + version = "0.13.2"; + src = ./.; + propagatedBuildInputs = [ cryptography ]; +})) diff --git a/third_party/python/broadlink/protocol.md b/third_party/python/broadlink/protocol.md new file mode 100644 index 0000000000..2e388d7499 --- /dev/null +++ b/third_party/python/broadlink/protocol.md @@ -0,0 +1,202 @@ +Broadlink RM2 network protocol +============================== + +Encryption +---------- + +Packets include AES-based encryption in CBC mode. The initial key is 0x09, 0x76, 0x28, 0x34, 0x3f, 0xe9, 0x9e, 0x23, 0x76, 0x5c, 0x15, 0x13, 0xac, 0xcf, 0x8b, 0x02. The IV is 0x56, 0x2e, 0x17, 0x99, 0x6d, 0x09, 0x3d, 0x28, 0xdd, 0xb3, 0xba, 0x69, 0x5a, 0x2e, 0x6f, 0x58. + +Checksum +-------- + +Construct the packet and set checksum bytes to zero. Add each byte to the starting value of 0xbeaf, wrapping after 0xffff. + +New device setup +---------------- + +To setup a new Broadlink device while in AP Mode a 136 byte packet needs to be sent to the device as follows: + +| Offset | Contents | +|---------|----------| +|0x00-0x19|00| +|0x20-0x21|Checksum as a little-endian 16 bit integer| +|0x26|14 (Always 14)| +|0x44-0x63|SSID Name (zero padding is appended)| +|0x64-0x83|Password (zero padding is appended)| +|0x84|Character length of SSID| +|0x85|Character length of password| +|0x86|Wireless security mode (00 - none, 01 = WEP, 02 = WPA1, 03 = WPA2, 04 = WPA1/2)| +|0x87-88|00| + +Send this packet as a UDP broadcast to 255.255.255.255 on port 80. + +Network discovery +----------------- + +To discover Broadlink devices on the local network, send a 48 byte packet with the following contents: + +| Offset | Contents | +|---------|----------| +|0x00-0x07|00| +|0x08-0x0b|Current offset from GMT as a little-endian 32 bit integer| +|0x0c-0x0d|Current year as a little-endian 16 bit integer| +|0x0e|Current number of seconds past the minute| +|0x0f|Current number of minutes past the hour| +|0x10|Current number of hours past midnight| +|0x11|Current day of the week (Monday = 1, Tuesday = 2, etc)| +|0x12|Current day in month| +|0x13|Current month| +|0x14-0x17|00| +|0x18-0x1b|Local IP address| +|0x1c-0x1d|Source port as a little-endian 16 bit integer| +|0x1e-0x1f|00| +|0x20-0x21|Checksum as a little-endian 16 bit integer| +|0x22-0x25|00| +|0x26|06| +|0x27-0x2f|00| + +Send this packet as a UDP broadcast to 255.255.255.255 on port 80. + +Response (any unicast response): + +| Offset | Contents | +|---------|----------| +|0x34-0x35|Device type as a little-endian 16 bit integer (see device type mapping)| +|0x3a-0x3f|MAC address of the target device| + +Device type mapping: + +| Device type in response packet | Device type | Treat as | +|---------|----------|----------| +|0|SP1|SP1| +|0x2711|SP2|SP2| +|0x2719 or 0x7919 or 0x271a or 0x791a|Honeywell SP2|SP2| +|0x2720|SPMini|SP2| +|0x753e|SP3|SP2| +|0x2728|SPMini2|SP2 +|0x2733 or 0x273e|OEM branded SPMini|SP2| +|>= 0x7530 and <= 0x7918|OEM branded SPMini2|SP2| +|0x2736|SPMiniPlus|SP2| +|0x2712|RM2|RM| +|0x2737|RM Mini / RM3 Mini Blackbean|RM| +|0x273d|RM Pro Phicomm|RM| +|0x2783|RM2 Home Plus|RM| +|0x277c|RM2 Home Plus GDT|RM| +|0x272a|RM2 Pro Plus|RM| +|0x2787|RM2 Pro Plus2|RM| +|0x278b|RM2 Pro Plus BL|RM| +|0x278f|RM Mini Shate|RM| +|0x2714|A1|A1| +|0x4EB5|MP1|MP1| + + +Command packet format +--------------------- + +The command packet header is 56 bytes long with the following format: + +|Offset|Contents| +|------|--------| +|0x00|0x5a| +|0x01|0xa5| +|0x02|0xaa| +|0x03|0x55| +|0x04|0x5a| +|0x05|0xa5| +|0x06|0xaa| +|0x07|0x55| +|0x08-0x1f|00| +|0x20-0x21|Checksum of full packet as a little-endian 16 bit integer| +|0x22-0x23|00| +|0x24-0x25|Device type as a little-endian 16 bit integer| +|0x26-0x27|Command code as a little-endian 16 bit integer| +|0x28-0x29|Packet count as a little-endian 16 bit integer| +|0x2a-0x2f|Local MAC address| +|0x30-0x33|Local device ID (obtained during authentication, 00 before authentication)| +|0x34-0x35|Checksum of unencrypted payload as a little-endian 16 bit integer +|0x36-0x37|00| + +The payload is appended immediately after this. The checksum at 0x20 is calculated *after* the payload is appended, and covers the entire packet (including the checksum at 0x34). Therefore: + +1. Generate packet header with checksum values set to 0 +2. Set the checksum initialisation value to 0xbeaf and calculate the checksum of the unencrypted payload. Set 0x34-0x35 to this value. +3. Encrypt and append the payload +4. Set the checksum initialisation value to 0xbeaf and calculate the checksum of the entire packet. Set 0x20-0x21 to this value. + +Authorisation +------------- + +You must obtain an authorisation key from the device before you can communicate. To do so, generate an 80 byte packet with the following contents: + +|Offset|Contents| +|------|--------| +|0x00-0x03|00| +|0x04-0x12|A 15-digit value that represents this device. Broadlink's implementation uses the IMEI.| +|0x13|01| +|0x14-0x2c|00| +|0x2d|0x01| +|0x30-0x7f|NULL-terminated ASCII string containing the device name| + +Send this payload with a command value of 0x0065. The response packet will contain an encrypted payload from byte 0x38 onwards. Decrypt this using the default key and IV. The format of the decrypted payload is: + +|Offset|Contents| +|------|--------| +|0x00-0x03|Device ID| +|0x04-0x13|Device encryption key| + +All further command packets must use this encryption key and device ID. + +Entering learning mode +---------------------- + +Send the following 16 byte payload with a command value of 0x006a: + +|Offset|Contents| +|------|--------| +|0x00|0x03| +|0x01-0x0f|0x00| + +Reading back data from learning mode +------------------------------------ + +Send the following 16 byte payload with a command value of 0x006a: + +|Offset|Contents| +|------|--------| +|0x00|0x04| +|0x01-0x0f|0x00| + +Byte 0x22 of the response contains a little-endian 16 bit error code. If this is 0, a code has been obtained. Bytes 0x38 and onward of the response are encrypted. Decrypt them. Bytes 0x04 and onward of the decrypted payload contain the captured data. + +Sending data +------------ + +Send the following payload with a command byte of 0x006a + +|Offset|Contents| +|------|--------| +|0x00|0x02| +|0x01-0x03|0x00| +|0x04|0x26 = IR, 0xb2 for RF 433Mhz, 0xd7 for RF 315Mhz| +|0x05|repeat count, (0 = no repeat, 1 send twice, .....)| +|0x06-0x07|Length of the following data in little endian| +|0x08 ....|Pulse lengths in 2^-15 s units (µs * 269 / 8192 works very well)| +|....|0x0d 0x05 at the end for IR only| + +Each value is represented by one byte. If the length exceeds one byte +then it is stored big endian with a leading 0. + +Example: The header for my Optoma projector is 8920 4450 +8920 * 269 / 8192 = 0x124 +4450 * 269 / 8192 = 0x92 + +So the data starts with `0x00 0x1 0x24 0x92 ....` + + +Todo +---- + +* Support for other devices using the Broadlink protocol (various smart home devices) +* Figure out what the format of the data packets actually is. +* Deal with the response after AP Mode WiFi network setup. + diff --git a/third_party/python/broadlink/requirements.txt b/third_party/python/broadlink/requirements.txt new file mode 100644 index 0000000000..09f445bfd8 --- /dev/null +++ b/third_party/python/broadlink/requirements.txt @@ -0,0 +1 @@ +cryptography==2.6.1 diff --git a/third_party/python/broadlink/setup.py b/third_party/python/broadlink/setup.py new file mode 100644 index 0000000000..778f495fb5 --- /dev/null +++ b/third_party/python/broadlink/setup.py @@ -0,0 +1,29 @@ +#!/usr/bin/env python +# -*- coding: utf-8 -*- + + +from setuptools import setup, find_packages + + +version = '0.13.2' + +setup( + name='broadlink', + version=version, + author='Matthew Garrett', + author_email='mjg59@srcf.ucam.org', + url='http://github.com/mjg59/python-broadlink', + packages=find_packages(), + scripts=[], + install_requires=['cryptography>=2.1.1'], + description='Python API for controlling Broadlink IR controllers', + classifiers=[ + 'Development Status :: 4 - Beta', + 'Intended Audience :: Developers', + 'License :: OSI Approved :: MIT License', + 'Operating System :: OS Independent', + 'Programming Language :: Python', + ], + include_package_data=True, + zip_safe=False, +) diff --git a/third_party/rust-crates/OWNERS b/third_party/rust-crates/OWNERS new file mode 100644 index 0000000000..d2bb7704b6 --- /dev/null +++ b/third_party/rust-crates/OWNERS @@ -0,0 +1,3 @@ +fogti +sterni +Profpatsch diff --git a/third_party/rust-crates/default.nix b/third_party/rust-crates/default.nix new file mode 100644 index 0000000000..2b7fe405bc --- /dev/null +++ b/third_party/rust-crates/default.nix @@ -0,0 +1,409 @@ +{ depot, pkgs, ... }: + +# TVL tool rust crate dependencies, where tools like carnix are not used. +# Intended for manual updates, which makes sure we never actually update. + +let + buildRustCrate = + attrs@{ edition ? "2018" + , pname + , crateName ? pname + , ... + }: pkgs.buildRustCrate (attrs // { + inherit + crateName + edition + ; + }); +in +depot.nix.readTree.drvTargets rec{ + cfg-if = buildRustCrate { + pname = "cfg-if"; + version = "1.0.0"; + sha256 = "1fzidq152hnxhg4lj6r2gv4jpnn8yivp27z6q6xy7w6v0dp6bai9"; + }; + + cc = buildRustCrate { + pname = "cc"; + version = "1.0.66"; + sha256 = "12q71z6ck8wlqrwgi25x3lrryyks9djymswn9b1c6qq0i01jpc1p"; + }; + + ascii = buildRustCrate { + pname = "ascii"; + version = "1.0.0"; + edition = "2015"; + sha256 = "0gam8xsn981wfa40srsniivffjsfz1pg0xnigmczk9k7azb1ks1m"; + }; + + regex-syntax = buildRustCrate { + pname = "regex-syntax"; + version = "0.6.25"; + edition = "2015"; + sha256 = "0i211p26m97ii169g0f4gf2a99r8an4xc1fdqj0sf5wpn17qhs29"; + }; + + regex = buildRustCrate { + pname = "regex"; + version = "1.5.5"; + features = [ "std" ]; + dependencies = [ regex-syntax ]; + edition = "2018"; + sha256 = "0i7yrxsvxpx682vdbkvj7j4w3a3z2c1qwmaa795mm9a9prx4yzjk"; + }; + + libloading = buildRustCrate { + pname = "libloading"; + version = "0.6.7"; + dependencies = [ cfg-if ]; + edition = "2015"; + sha256 = "111d8zsizswnxiqn43vcgnc2ym9spsx1i6pcfp35ca3yw2ixq95j"; + }; + + tree-sitter = buildRustCrate { + pname = "tree-sitter"; + # buildRustCrate isn’t really smart enough to detect the subdir + libPath = "binding_rust/lib.rs"; + # and the build.rs is also not where buildRustCrate would find it + build = "binding_rust/build.rs"; + version = "0.17.1"; + dependencies = [ regex ]; + buildDependencies = [ cc ]; + sha256 = "0jwwbvs4icpra7m1ycvnyri5h3sbw4qrfvgnnvnk72h4w93qhzhr"; + }; + + libc = buildRustCrate { + pname = "libc"; + version = "0.2.82"; + edition = "2015"; + sha256 = "02zgn6c0xwh331hky417lbr29kmvrw3ylxs8822syyhjfjqszvsx"; + }; + + bitflags = buildRustCrate { + pname = "bitflags"; + version = "1.2.1"; + sha256 = "0b77awhpn7yaqjjibm69ginfn996azx5vkzfjj39g3wbsqs7mkxg"; + }; + + inotify-sys = buildRustCrate { + pname = "inotify-sys"; + version = "0.1.5"; + dependencies = [ libc ]; + sha256 = "1yiy577xxhi0j90nbg9nkd8cqwc1xix62rz55jjngvxa5jl5613v"; + }; + + inotify = buildRustCrate { + pname = "inotify"; + version = "0.9.2"; + dependencies = [ bitflags libc inotify-sys ]; + sha256 = "0fcknyvknglwwk1pdzdlb4m0ry2dym1yx8r5prf2v00pxnjk0hv2"; + }; + + httparse = buildRustCrate { + pname = "httparse"; + version = "1.3.4"; + edition = "2015"; + sha256 = "0dggj4s0cq69bn63q9nqzzay5acmwl33nrbhjjsh5xys8sk2x4jw"; + }; + + version-check = buildRustCrate { + pname = "version_check"; + version = "0.9.2"; + edition = "2015"; + sha256 = "1vwvc1mzwv8ana9jv8z933p2xzgj1533qwwl5zr8mi89azyhq21v"; + }; + + memchr = buildRustCrate { + pname = "memchr"; + version = "2.3.3"; + edition = "2015"; + sha256 = "1ivxvlswglk6wd46gadkbbsknr94gwryk6y21v64ja7x4icrpihw"; + }; + nom = buildRustCrate { + pname = "nom"; + version = "5.1.1"; + sha256 = "1gb4r6mjwd645jqh02nhn60i7qkw8cgy3xq1r4clnmvz3cmkv1l0"; + dependencies = [ memchr ]; + buildDependencies = [ version-check ]; + features = [ "std" "alloc" ]; + }; + + base64 = buildRustCrate { + pname = "base64"; + version = "0.13.0"; + sha256 = "0i0jk5sgq37kc4c90d1g7dp7zvphbg0dbqc1ajnn0vffjxblgamg"; + features = [ "alloc" "std" ]; + }; + + bufstream = buildRustCrate { + pname = "bufstream"; + version = "0.1.4"; + sha256 = "10rqm7jly5jjx7wcc19q6q4m2zsrw3l2v3m1054wnbwvdh42xxf1"; + }; + + autocfg = buildRustCrate { + pname = "autocfg"; + version = "1.0.1"; + edition = "2015"; + sha256 = "1lsjz23jdcchcqbsmlzd4iksg3hc8bdvy677jy0938i2gp24frw1"; + }; + + num-traits = buildRustCrate { + pname = "num-traits"; + version = "0.2.14"; + edition = "2015"; + buildDependencies = [ autocfg ]; + sha256 = "09ac9dcp6cr57vjzyiy213y7312jqcy84mkamp99zr40qd1gwnyk"; + }; + + num-integer = buildRustCrate { + pname = "num-integer"; + version = "0.1.44"; + edition = "2015"; + dependencies = [ num-traits ]; + buildDependencies = [ autocfg ]; + sha256 = "1gdbnfgnivp90h644wmqj4a20yfmdga2xxxacx53pjbcazvfvajc"; + }; + + chrono = buildRustCrate { + pname = "chrono"; + version = "0.4.22"; + edition = "2018"; + dependencies = [ num-traits num-integer ]; + features = [ "alloc" "std" ]; + sha256 = "01vbn93ba1q2afq10qis41j847damk5ifgn1all337mcscl345fn"; + }; + + imap-proto = buildRustCrate { + pname = "imap-proto"; + version = "0.10.2"; + dependencies = [ nom ]; + sha256 = "1bf5r4d0z7c8wxrvr7kjy26500wr7cd4sxz49ix3b3yzc6ayyqv1"; + }; + + lazy_static = buildRustCrate { + pname = "lazy_static"; + version = "1.4.0"; + sha256 = "13h6sdghdcy7vcqsm2gasfw3qg7ssa0fl3sw7lq6pdkbk52wbyfr"; + }; + + imap = buildRustCrate { + pname = "imap"; + version = "2.4.0"; + dependencies = [ + base64 + bufstream + chrono + imap-proto + lazy_static + nom + regex + ]; + sha256 = "1nj6x45qnid98nv637623rrh7imcxk0kad89ry8j5dkkgccvjyc0"; + }; + + epoll = buildRustCrate { + pname = "epoll"; + version = "4.3.1"; + dependencies = [ bitflags libc ]; + sha256 = "0dgmgdmrfbjkpxn1w3xmmwsm2a623a9qdwn90s8yl78n4a36kbh9"; + }; + + serde = buildRustCrate { + pname = "serde"; + version = "1.0.123"; + edition = "2015"; + sha256 = "05xl2s1vpf3p7fi2yc9qlzw88d5ap0z3qmhmd7axa6pp9pn1s5xc"; + features = [ "std" ]; + }; + + ryu = buildRustCrate { + pname = "ryu"; + version = "1.0.5"; + sha256 = "060y2ln1csix593ingwxr2y3wl236ls0ly1ffkv39h5im7xydhrc"; + }; + + itoa = buildRustCrate { + pname = "itoa"; + version = "0.4.7"; + sha256 = "0079jlkcmcaw37wljrvb6r3dqq15nfahkqnl5npvlpdvkg31k11x"; + }; + + serde_json = buildRustCrate { + pname = "serde_json"; + version = "1.0.62"; + sha256 = "0sgc8dycigq0nxr4j613m4q733alfb2i10s6nz80lsbbqgrka21q"; + dependencies = [ serde ryu itoa ]; + features = [ "std" ]; + }; + + log = buildRustCrate { + pname = "log"; + version = "0.4.11"; + sha256 = "0m6xhqxsps5mgd7r91g5mqkndbh8zbjd58p7w75r330zl4n40l07"; + dependencies = [ cfg-if ]; + }; + + mustache = buildRustCrate { + pname = "mustache"; + version = "0.9.0"; + edition = "2015"; + sha256 = "1zgl8l15i19lzp90icgwyi6zqdd31b9vm8w129f41d1zd0hs7ayq"; + dependencies = [ log serde ]; + }; + + semver-parser = buildRustCrate { + pname = "semver-parser"; + version = "0.7.0"; + edition = "2015"; + sha256 = "1da66c8413yakx0y15k8c055yna5lyb6fr0fw9318kdwkrk5k12h"; + }; + + semver = buildRustCrate { + pname = "semver"; + version = "0.10.0"; + edition = "2015"; + sha256 = "0pbkdwlpq4d0hgdrymm2rcw31plni2siwd882gbcbscjvyvrrrqa"; + dependencies = [ semver-parser ]; + }; + + toml = buildRustCrate { + pname = "toml"; + version = "0.5.8"; + sha256 = "1vwjwmwsy83pbgvvm11a6grbhb09zkcrv9v95wfwv48wjm01wdj4"; + edition = "2018"; + dependencies = [ serde ]; + }; + + pkg-config = buildRustCrate { + pname = "pkg-config"; + version = "0.3.19"; + sha256 = "1kd047p8jv6mhmfzddjvfa2nwkfrb3l1wml6lfm51n1cr06cc9lz"; + }; + + libz-sys = buildRustCrate { + pname = "libz-sys"; + version = "1.1.2"; + sha256 = "1y7v6bkwr4b6yaf951p1ns7mx47b29ziwdd5wziaic14gs1gwq30"; + buildDependencies = [ + cc + pkg-config + ]; + }; + + libgit2-sys = buildRustCrate { + pname = "libgit2-sys"; + version = "0.12.26+1.3.0"; + sha256 = "15zg0yy7lk7464yf9i1kxh4gaxdyb8m96ayb7vkjgmz1s2rgq7s2"; + dependencies = [ + libc + libz-sys + ]; + libPath = "lib.rs"; + libName = "libgit2_sys"; + # TODO: this should be available via `pkgs.defaultCrateOverrides`, + # I thought that was included by default? + nativeBuildInputs = [ pkg-config ]; + buildInputs = [ pkgs.zlib pkgs.libgit2 ]; + buildDependencies = [ + cc + pkg-config + ]; + }; + + matches = buildRustCrate { + pname = "matches"; + version = "0.1.8"; + sha256 = "03hl636fg6xggy0a26200xs74amk3k9n0908rga2szn68agyz3cv"; + libPath = "lib.rs"; + }; + + percent-encoding = buildRustCrate { + pname = "percent-encoding"; + version = "2.1.0"; + sha256 = "0i838f2nr81585ckmfymf8l1x1vdmx6n8xqvli0lgcy60yl2axy3"; + libPath = "lib.rs"; + }; + + form_urlencoded = buildRustCrate { + pname = "form_urlencoded"; + version = "1.0.1"; + sha256 = "0rhv2hfrzk2smdh27walkm66zlvccnnwrbd47fmf8jh6m420dhj8"; + dependencies = [ + matches + percent-encoding + ]; + }; + + tinyvec_macros = buildRustCrate { + pname = "tinyvec_macros"; + version = "0.1.0"; + sha256 = "0aim73hyq5g8b2hs9gjq2sv0xm4xzfbwp5fdyg1frljqzkapq682"; + }; + + tinyvec = buildRustCrate { + pname = "tinyvec"; + version = "1.2.0"; + sha256 = "1c95nma20kiyrjwfsk7hzd5ir6yy4bm63fmfbfb4dm9ahnlvdp3y"; + features = [ "alloc" ]; + dependencies = [ + tinyvec_macros + ]; + }; + + unicode-normalization = buildRustCrate { + pname = "unicode-normalization"; + version = "0.1.17"; + sha256 = "0w4s0avzlf7pzcclhhih93aap613398sshm6jrxcwq0f9lhis11c"; + dependencies = [ + tinyvec + ]; + }; + + unicode-bidi = buildRustCrate { + pname = "unicode-bidi"; + version = "0.3.5"; + sha256 = "193jzlxj1dfcms2381lyd45zh4ywlicj9lzcfpid1zbkmfarymkz"; + dependencies = [ + matches + ]; + }; + + idna = buildRustCrate { + pname = "idna"; + version = "0.2.3"; + sha256 = "0hwypd0fpym9lmd4bbqpwyr5lhrlvmvzhi1vy9asc5wxwkzrh299"; + dependencies = [ + matches + unicode-normalization + unicode-bidi + ]; + }; + + url = buildRustCrate { + pname = "url"; + version = "2.2.1"; + sha256 = "1ci1djafh83qhpzbmxnr9w5gcrjs3ghf8rrxdy4vklqyji6fvn5v"; + dependencies = [ + form_urlencoded + idna + matches + percent-encoding + ]; + }; + + + git2 = buildRustCrate { + pname = "git2"; + edition = "2018"; + version = "0.13.25"; + sha256 = "181mw4kxsqrwpib9kf25fykc48wxhjla37vzis4j0b0w0yhyaqi3"; + dependencies = [ + bitflags + libc + libgit2-sys + log + url + ]; + }; +} diff --git a/third_party/rustsec-advisory-db/default.nix b/third_party/rustsec-advisory-db/default.nix new file mode 100644 index 0000000000..e0ea2b080a --- /dev/null +++ b/third_party/rustsec-advisory-db/default.nix @@ -0,0 +1,19 @@ +# RustSec's advisory db for crates +{ pkgs, depot, ... }: + +let + inherit (depot.third_party.sources) rustsec-advisory-db; +in + +pkgs.fetchFromGitHub { + inherit (rustsec-advisory-db) + owner + repo + sha256 + rev + ; + + passthru = { + inherit (rustsec-advisory-db) rev; + }; +} diff --git a/third_party/smtprelay/default.nix b/third_party/smtprelay/default.nix new file mode 100644 index 0000000000..1a68245e92 --- /dev/null +++ b/third_party/smtprelay/default.nix @@ -0,0 +1,21 @@ +# A simple SMTP relay without the kitchen sink. +{ pkgs, lib, ... }: + +pkgs.buildGoModule rec { + pname = "smtprelay"; + version = "1.7.0"; + vendorHash = "sha256:00nb81hdg5pv5l0q7w5lv08dv4v72vml7jha351frani0gpg27pn"; + + src = pkgs.fetchFromGitHub { + owner = "decke"; + repo = "smtprelay"; + rev = "v${version}"; + sha256 = "0js18xhk64g0g82dx8ii8vhbbssj3pxf1hqv1zadnckdgwfwlj2r"; + }; + + meta = with lib; { + description = "Simple Golang SMTP relay/proxy server"; + homepage = https://github.com/decke/smtprelay; + license = licenses.mit; + }; +} diff --git a/third_party/sources/default.nix b/third_party/sources/default.nix new file mode 100644 index 0000000000..5894c92079 --- /dev/null +++ b/third_party/sources/default.nix @@ -0,0 +1,151 @@ +# This file has been generated by Niv. +_: +let + + # + # The fetchers. fetch_<type> fetches specs of type <type>. + # + + fetch_file = pkgs: spec: + if spec.builtin or true then + builtins_fetchurl { inherit (spec) url sha256; } + else + pkgs.fetchurl { inherit (spec) url sha256; }; + + fetch_tarball = pkgs: name: spec: + let + ok = str: ! builtins.isNull (builtins.match "[a-zA-Z0-9+-._?=]" str); + # sanitize the name, though nix will still fail if name starts with period + name' = stringAsChars (x: if ! ok x then "-" else x) "${name}-src"; + in + if spec.builtin or true then + builtins_fetchTarball { name = name'; inherit (spec) url sha256; } + else + pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; + + fetch_git = spec: + builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; }; + + fetch_local = spec: spec.path; + + fetch_builtin-tarball = name: throw + ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. + $ niv modify ${name} -a type=tarball -a builtin=true''; + + fetch_builtin-url = name: throw + ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. + $ niv modify ${name} -a type=file -a builtin=true''; + + # + # Various helpers + # + + # The set of packages used when specs are fetched using non-builtins. + mkPkgs = sources: + let + sourcesNixpkgs = + import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { }; + hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; + hasThisAsNixpkgsPath = <nixpkgs> == ./.; + in + if builtins.hasAttr "nixpkgs" sources + then sourcesNixpkgs + else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then + import <nixpkgs> { } + else + abort + '' + Please specify either <nixpkgs> (through -I or NIX_PATH=nixpkgs=...) or + add a package called "nixpkgs" to your sources.json. + ''; + + # The actual fetching function. + fetch = pkgs: name: spec: + + if ! builtins.hasAttr "type" spec then + abort "ERROR: niv spec ${name} does not have a 'type' attribute" + else if spec.type == "file" then fetch_file pkgs spec + else if spec.type == "tarball" then fetch_tarball pkgs name spec + else if spec.type == "git" then fetch_git spec + else if spec.type == "local" then fetch_local spec + else if spec.type == "builtin-tarball" then fetch_builtin-tarball name + else if spec.type == "builtin-url" then fetch_builtin-url name + else + abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; + + # If the environment variable NIV_OVERRIDE_${name} is set, then use + # the path directly as opposed to the fetched source. + replace = name: drv: + let + saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; + ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; + in + if ersatz == "" then drv else ersatz; + + # Ports of functions for older nix versions + + # a Nix version of mapAttrs if the built-in doesn't exist + mapAttrs = builtins.mapAttrs or ( + f: set: with builtins; + listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) + ); + + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 + range = first: last: if first > last then [ ] else builtins.genList (n: first + n) (last - first + 1); + + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 + stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); + + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 + stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); + concatStrings = builtins.concatStringsSep ""; + + # fetchTarball version that is compatible between all the versions of Nix + builtins_fetchTarball = { url, name, sha256 }@attrs: + let + inherit (builtins) lessThan nixVersion fetchTarball; + in + if lessThan nixVersion "1.12" then + fetchTarball { inherit name url; } + else + fetchTarball attrs; + + # fetchurl version that is compatible between all the versions of Nix + builtins_fetchurl = { url, sha256 }@attrs: + let + inherit (builtins) lessThan nixVersion fetchurl; + in + if lessThan nixVersion "1.12" then + fetchurl { inherit url; } + else + fetchurl attrs; + + # Create the final "sources" from the config + mkSources = config: + mapAttrs + ( + name: spec: + if builtins.hasAttr "outPath" spec + then + abort + "The values in sources.json should not have an 'outPath' attribute" + else + spec // { outPath = replace name (fetch config.pkgs name spec); } + ) + config.sources; + + # The "config" used by the fetchers + mkConfig = + { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null + , sources ? if isNull sourcesFile then { } else builtins.fromJSON (builtins.readFile sourcesFile) + , pkgs ? mkPkgs sources + }: rec { + # The sources, i.e. the attribute set of spec name to spec + inherit sources; + + # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers + inherit pkgs; + }; + +in +mkSources (mkConfig { }) // { __functor = _: settings: mkSources (mkConfig settings); } diff --git a/third_party/sources/sources.json b/third_party/sources/sources.json new file mode 100644 index 0000000000..0c5a4a0893 --- /dev/null +++ b/third_party/sources/sources.json @@ -0,0 +1,122 @@ +{ + "agenix": { + "branch": "main", + "description": "age-encrypted secrets for NixOS", + "homepage": "https://matrix.to/#/#agenix:nixos.org", + "owner": "ryantm", + "repo": "agenix", + "rev": "0.15.0", + "sha256": "01dhrghwa7zw93cybvx4gnrskqk97b004nfxgsys0736823956la", + "type": "tarball", + "url": "https://github.com/ryantm/agenix/archive/0.15.0.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" + }, + "emacs-overlay": { + "branch": "master", + "description": "Bleeding edge emacs overlay [maintainer=@adisbladis] ", + "homepage": "", + "owner": "nix-community", + "repo": "emacs-overlay", + "rev": "eb3071f959d2c4bd6eccd2176d43f33ccfbfb3b1", + "sha256": "0y0rk07yliak02mcis10caabz7dbd0wr2jf8sfdr40ar2dks84cl", + "type": "tarball", + "url": "https://github.com/nix-community/emacs-overlay/archive/eb3071f959d2c4bd6eccd2176d43f33ccfbfb3b1.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" + }, + "home-manager": { + "branch": "master", + "description": "Manage a user environment using Nix [maintainer=@rycee] ", + "homepage": "https://nix-community.github.io/home-manager/", + "owner": "nix-community", + "repo": "home-manager", + "rev": "d634c3abafa454551f2083b054cd95c3f287be61", + "sha256": "0mxrylbycywi8qh6zb1il5yfb5apbjsd7avhvfpavclkjaz80awb", + "type": "tarball", + "url": "https://github.com/nix-community/home-manager/archive/d634c3abafa454551f2083b054cd95c3f287be61.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" + }, + "impermanence": { + "branch": "master", + "description": "Modules to help you handle persistent state on systems with ephemeral root storage [maintainer=@talyz]", + "homepage": "", + "owner": "nix-community", + "repo": "impermanence", + "rev": "033643a45a4a920660ef91caa391fbffb14da466", + "sha256": "16x067nv146igqfxq8b3a0rf6715z5vpl0hz27dp2a29s6lr8944", + "type": "tarball", + "url": "https://github.com/nix-community/impermanence/archive/033643a45a4a920660ef91caa391fbffb14da466.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" + }, + "naersk": { + "branch": "master", + "description": "Build rust crates in Nix. No configuration, no code generation, no IFD. Sandbox friendly. [maintainer: @Patryk27]", + "homepage": "", + "owner": "nmattia", + "repo": "naersk", + "rev": "aeb58d5e8faead8980a807c840232697982d47b9", + "sha256": "185wg4p67krrjd8dx5h9pc381z7677nfzsdyp54kg3niqcf5wdzx", + "type": "tarball", + "url": "https://github.com/nmattia/naersk/archive/aeb58d5e8faead8980a807c840232697982d47b9.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" + }, + "napalm": { + "branch": "master", + "description": "Support for building npm packages in Nix and lightweight npm registry [maintainer @nmattia]", + "homepage": "", + "owner": "nix-community", + "repo": "napalm", + "rev": "edcb26c266ca37c9521f6a97f33234633cbec186", + "sha256": "0ai1ax380nnpz0mbgbc5vdzafyjilcmdj7kgv087x2vagpprb4yy", + "type": "tarball", + "url": "https://github.com/nix-community/napalm/archive/edcb26c266ca37c9521f6a97f33234633cbec186.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" + }, + "nixpkgs": { + "branch": "nixos-unstable", + "description": "Nix Packages collection", + "homepage": "", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "c002c6aa977ad22c60398daaa9be52f2203d0006", + "sha256": "1jzkx82rim9lqklfbjnf826r071avjlw60pgr8h2dad6m2nah2vp", + "type": "tarball", + "url": "https://github.com/NixOS/nixpkgs/archive/c002c6aa977ad22c60398daaa9be52f2203d0006.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" + }, + "nixpkgs-stable": { + "branch": "nixos-23.11", + "description": "Nix Packages collection", + "homepage": "", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "56911ef3403a9318b7621ce745f5452fb9ef6867", + "sha256": "0jf6pnz4s5w9p35wd584hy7p6r5aaq1khfdxv2c1nqnmss05nn2b", + "type": "tarball", + "url": "https://github.com/NixOS/nixpkgs/archive/56911ef3403a9318b7621ce745f5452fb9ef6867.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" + }, + "rust-overlay": { + "branch": "master", + "description": "Pure and reproducible nix overlay of binary distributed rust toolchains", + "homepage": "", + "owner": "oxalica", + "repo": "rust-overlay", + "rev": "883b84c426107a8ec020e7124f263d7c35a5bb9f", + "sha256": "0njzqw4agbn8xsavibf8dqg99yrpm12g1vbjgf0i309wy4cfazn6", + "type": "tarball", + "url": "https://github.com/oxalica/rust-overlay/archive/883b84c426107a8ec020e7124f263d7c35a5bb9f.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" + }, + "rustsec-advisory-db": { + "branch": "main", + "description": "Security advisory database for Rust crates published through crates.io", + "homepage": "https://rustsec.org", + "owner": "RustSec", + "repo": "advisory-db", + "rev": "1d2202ea2b32fabd3307641010301bfe187ef11a", + "sha256": "154njsibggh08v5n3aazc4a5x693dm1g1qxhfh2insc6ibkrpfj2", + "type": "tarball", + "url": "https://github.com/RustSec/advisory-db/archive/1d2202ea2b32fabd3307641010301bfe187ef11a.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" + } +} diff --git a/third_party/terraform-provider-glesys/default.nix b/third_party/terraform-provider-glesys/default.nix new file mode 100644 index 0000000000..2eea7e1905 --- /dev/null +++ b/third_party/terraform-provider-glesys/default.nix @@ -0,0 +1,20 @@ +# GleSYS Terraform provider +# +# Some TVL resources (DNS, object storage, ...) are hosted with them. +{ pkgs, ... }: + +pkgs.terraform-providers.mkProvider rec { + version = "0.9.0"; + spdx = "MPL-2.0"; + + owner = "glesys"; + repo = "terraform-provider-glesys"; + rev = "v${version}"; + hash = "sha256:0n2wb1gl0agc9agqlmhg4mh9kyfhw4zvrryyl8wfxlp1hkr0wz9y"; + + vendorHash = "sha256:13wdx7q5rsyjrm6cn030m5hgcvx0m17dhr16wmbfv71pmsszfdjm"; + + # This provider is not officially published in the TF registry, so + # we're giving it a fake source here. + provider-source-address = "registry.terraform.io/depot/glesys"; +} |
