Skip to content

Commit 37d657c

Browse files
author
cage
committed
- added a configuration directive to filter out unwanted hashtags.
1 parent ba320d8 commit 37d657c

File tree

5 files changed

+112
-81
lines changed

5 files changed

+112
-81
lines changed

‎src/db.lisp

+16-2
Original file line numberDiff line numberDiff line change
@@ -761,6 +761,14 @@
761761
(return-from boost-ignored-p t)))
762762
nil))
763763

764+
(defun tags-ignored-p (tags)
765+
"Returns non nil if theh tags of a status must be filtered out"
766+
(when-let ((ignore-regexps (swconf:ignore-tag-regexps)))
767+
(loop for ignore-re in ignore-regexps do
768+
(when (cl-ppcre:scan ignore-re tags)
769+
(return-from tags-ignored-p t)))
770+
nil))
771+
764772
(defun acct->user (acct)
765773
"Convert `acct' (acct is synonyym for username in mastodon account)
766774
to the corresponding row in table +table-account+"
@@ -1216,6 +1224,13 @@ than (swconf:config-purge-history-days-offset) days in the past"
12161224
(:and (:= :day actual-day)
12171225
(:= :tag tag)))))))))
12181226

1227+
(defun concat-tags (status)
1228+
(with-accessors ((tags tooter:tags)) status
1229+
(if tags
1230+
(join-with-strings (mapcar #'client:tag-name tags)
1231+
+tag-separator+)
1232+
"")))
1233+
12191234
(defmethod update-db ((object tooter:status)
12201235
&key
12211236
(timeline +local-timeline+)
@@ -1252,8 +1267,7 @@ than (swconf:config-purge-history-days-offset) days in the past"
12521267
(tag-names (if tags
12531268
(mapcar #'client:tag-name tags)
12541269
""))
1255-
(actual-tags (join-with-strings tag-names
1256-
+tag-separator+))
1270+
(actual-tags (concat-tags object))
12571271
(actual-language (prepare-for-db language))
12581272
;; use string-downcase as a workaround because tooter return an upcased keyword
12591273
(actual-visibility (string-downcase (prepare-for-db visibility)))

‎src/modeline-window.lisp

+1-1
Original file line numberDiff line numberDiff line change
@@ -82,7 +82,7 @@
8282
(mapping-code->fn mapping-code->fn)
8383
(parsed-modeline parsed-modeline)) object
8484
;; parsed is like '("foo" (:key "a") "bar" ...)
85-
(let ((res (make-tui-string "")))
85+
(let ((res (make-tui-string "")))
8686
(loop for i in parsed-modeline do
8787
(let ((executed (cond
8888
((listp i)

‎src/package.lisp

+2
Original file line numberDiff line numberDiff line change
@@ -861,6 +861,7 @@
861861
:account-ignored-p
862862
:user-ignored-p
863863
:boost-ignored-p
864+
:tags-ignored-p
864865
:acct->user
865866
:acct->id
866867
:username->id
@@ -1241,6 +1242,7 @@
12411242
:color-regexps
12421243
:ignore-users-regexps
12431244
:ignore-users-boost-regexps
1245+
:ignore-tag-regexps
12441246
:win-bg
12451247
:win-fg
12461248
:win-height

‎src/program-events.lisp

+3
Original file line numberDiff line numberDiff line change
@@ -388,6 +388,7 @@
388388
(status-id (tooter:id status))
389389
(language (tooter:language status))
390390
(rebloggedp (tooter:parent status))
391+
(tags (db::concat-tags status))
391392
(skip-this-status nil))
392393
(when force-saving-of-ignored-status-p
393394
(db:remove-from-status-ignored status-id folder timeline-type))
@@ -398,6 +399,8 @@
398399
language))
399400
(and rebloggedp
400401
(db:boost-ignored-p account-id))
402+
(and (text-utils:string-not-empty-p tags)
403+
(db:tags-ignored-p tags))
401404
(hooks:run-hook-until-success 'hooks:*skip-message-hook*
402405
status
403406
timeline-type

‎src/software-configuration.lisp

+90-78
Original file line numberDiff line numberDiff line change
@@ -17,85 +17,87 @@
1717

1818
(in-package :software-configuration)
1919

20-
;; CONFIG := (ENTRIES)*
21-
;; ENTRIES := COMMENT*
22-
;; (USE-FILE
23-
;; | IGNORE-USER-RE-ASSIGN
24-
;; | IGNORE-USER-BOOST-RE-ASSIGN
25-
;; | COLOR-RE-ASSIGN
26-
;; | SERVER-ASSIGN
27-
;; | USERNAME-ASSIGN
28-
;; | OPEN-LINK-HELPER
29-
;; | POST-ALLOWED-LANGUAGE
30-
;; | GENERIC-ASSIGN)
31-
;; COMMENT*
32-
;; SERVER-ASSIGN := SERVER-KEY BLANKS ASSIGN BLANKS GENERIC-VALUE BLANKS
33-
;; USERNAME-ASSIGN := USERNAME-KEY BLANKS WITH BLANKS GENERIC-VALUE BLANKS
34-
;; OPEN-LINK-HELPER := OPEN-LINK-HELPER-KEY BLANKS ASSIGN BLANKS
35-
;; REGEXP PROGRAM-NAME BLANKS USE-CACHE? NOWAIT?
36-
;; GENERIC-ASSIGN := (and key blanks assign blanks
37-
;; (or quoted-string
38-
;; hexcolor
39-
;; colorname
40-
;; generic-value) ; the order in this list *is* important
41-
;; blanks)
42-
;; IGNORE-USER-RE-ASSIGN := IGNORE-USER-RE-KEY ASSIGN REGEXP
20+
;; CONFIG := (ENTRIES)*
21+
;; ENTRIES := COMMENT*
22+
;; (USE-FILE
23+
;; | IGNORE-USER-RE-ASSIGN
24+
;; | IGNORE-USER-BOOST-RE-ASSIGN
25+
;; | IGNORE-TAG-RE-ASSIGN
26+
;; | COLOR-RE-ASSIGN
27+
;; | SERVER-ASSIGN
28+
;; | USERNAME-ASSIGN
29+
;; | OPEN-LINK-HELPER
30+
;; | POST-ALLOWED-LANGUAGE
31+
;; | GENERIC-ASSIGN)
32+
;; COMMENT*
33+
;; SERVER-ASSIGN := SERVER-KEY BLANKS ASSIGN BLANKS GENERIC-VALUE BLANKS
34+
;; USERNAME-ASSIGN := USERNAME-KEY BLANKS WITH BLANKS GENERIC-VALUE BLANKS
35+
;; OPEN-LINK-HELPER := OPEN-LINK-HELPER-KEY BLANKS ASSIGN BLANKS
36+
;; REGEXP PROGRAM-NAME BLANKS USE-CACHE? NOWAIT?
37+
;; GENERIC-ASSIGN := (and key blanks assign blanks
38+
;; (or quoted-string
39+
;; hexcolor
40+
;; colorname
41+
;; generic-value) ; the order in this list *is* important
42+
;; blanks)
43+
;; IGNORE-USER-RE-ASSIGN := IGNORE-USER-RE-KEY ASSIGN REGEXP
4344
;; IGNORE-USER-BOOST-RE-ASSIGN := IGNORE-USER-RE-KEY ASSIGN REGEXP
44-
;; COLOR-RE-ASSIGN := COLOR-RE-KEY ASSIGN REGEXP FG-COLOR (? ATTRIBUTE-VALUE)
45-
;; USE-FILE := (AND USE BLANKS FILEPATH BLANKS)
46-
;; POST-ALLOWED-LANGUAGE := "post-allowed-language" BLANKS ASSIGN REGEXP
47-
;; KEY := FIELD (FIELD-SEPARATOR KEY)*
48-
;; BLANKS := (BLANK)*
49-
;; FILEPATH := QUOTED-STRING
50-
;; PROGRAM-NAME := QUOTED-STRING
51-
;; USE-CACHE := USE BLANKS CACHE
52-
;; NOWAIT := NO BLANKS WAIT BLANKS (BUFFER-LABEL BLANKS DIGIT+)?
53-
;; NO := "no"
54-
;; WAIT := "wait"
55-
;; CACHE := "cache"
56-
;; USE := "use"
57-
;; SERVER-KEY := "server"
58-
;; USERNAME-KEY := "username"
59-
;; COLOR-RE-KEY := "color-regexp"
60-
;; IGNORE-USER-RE-KEY := "ignore-user-regexp"
61-
;; OPEN := "open"
62-
;; OPEN-LINK-HELPER-KEY := OPEN
63-
;; WITH-KEY := "with"
64-
;; BUFFER-LABEL := "buffer"
65-
;; REGEXP := QUOTED-STRING
66-
;; QUOTED-STRING := #\" (not #\") #\"
67-
;; FIELD := ( (or ESCAPED-CHARACTER
68-
;; (not #\# ASSIGN BLANK FIELD-SEPARATOR) )*
69-
;; COMMENT := BLANKS #\# (not #\Newline)* BLANKS
70-
;; FIELD-SEPARATOR := #\.
71-
;; GENERIC-VALUE := KEY
72-
;; ASSIGN := #\=
73-
;; BLANK := (or #\space #\Newline #\Tab)
74-
;; BG-COLOR := COLOR
75-
;; FG-COLOR := COLOR
76-
;; COLOR := HEX-COLOR | COLOR-NAME
77-
;; HEX-COLOR := HEXCOLOR-PREFIX
78-
;; HEXDIGIT HEXDIGIT -> red
79-
;; HEXDIGIT HEXDIGIT -> green
80-
;; HEXDIGIT HEXDIGIT -> blue
81-
;; ESCAPED-CHARACTER := #\\ any-character
82-
;; HEXCOLOR-PREFIX := #\#
83-
;; HEX-DIGIT := (and (character-ranges #\0 #\9)
84-
;; (character-ranges #\a #\f)
85-
;; (character-ranges #\A #\f)
86-
;; DIGIT := (character-ranges #\0 #\9)
87-
;; ATTRIBUTE-VALUE := "bold"
88-
;; | "italic"
89-
;; | "underline"
90-
;; | "blink"
91-
;; COLOR-NAME := "black"
92-
;; | "red"
93-
;; | "green"
94-
;; | "yellow"
95-
;; | "blue"
96-
;; | "magenta"
97-
;; | "cyan"
98-
;; | "white"
45+
;; IGNORE-TAG-RE-ASSIGN := IGNORE-USER-RE-KEY ASSIGN REGEXP
46+
;; COLOR-RE-ASSIGN := COLOR-RE-KEY ASSIGN REGEXP FG-COLOR (? ATTRIBUTE-VALUE)
47+
;; USE-FILE := (AND USE BLANKS FILEPATH BLANKS)
48+
;; POST-ALLOWED-LANGUAGE := "post-allowed-language" BLANKS ASSIGN REGEXP
49+
;; KEY := FIELD (FIELD-SEPARATOR KEY)*
50+
;; BLANKS := (BLANK)*
51+
;; FILEPATH := QUOTED-STRING
52+
;; PROGRAM-NAME := QUOTED-STRING
53+
;; USE-CACHE := USE BLANKS CACHE
54+
;; NOWAIT := NO BLANKS WAIT BLANKS (BUFFER-LABEL BLANKS DIGIT+)?
55+
;; NO := "no"
56+
;; WAIT := "wait"
57+
;; CACHE := "cache"
58+
;; USE := "use"
59+
;; SERVER-KEY := "server"
60+
;; USERNAME-KEY := "username"
61+
;; COLOR-RE-KEY := "color-regexp"
62+
;; IGNORE-USER-RE-KEY := "ignore-user-regexp"
63+
;; OPEN := "open"
64+
;; OPEN-LINK-HELPER-KEY := OPEN
65+
;; WITH-KEY := "with"
66+
;; BUFFER-LABEL := "buffer"
67+
;; REGEXP := QUOTED-STRING
68+
;; QUOTED-STRING := #\" (not #\") #\"
69+
;; FIELD := ( (or ESCAPED-CHARACTER
70+
;; (not #\# ASSIGN BLANK FIELD-SEPARATOR) )*
71+
;; COMMENT := BLANKS #\# (not #\Newline)* BLANKS
72+
;; FIELD-SEPARATOR := #\.
73+
;; GENERIC-VALUE := KEY
74+
;; ASSIGN := #\=
75+
;; BLANK := (or #\space #\Newline #\Tab)
76+
;; BG-COLOR := COLOR
77+
;; FG-COLOR := COLOR
78+
;; COLOR := HEX-COLOR | COLOR-NAME
79+
;; HEX-COLOR := HEXCOLOR-PREFIX
80+
;; HEXDIGIT HEXDIGIT -> red
81+
;; HEXDIGIT HEXDIGIT -> green
82+
;; HEXDIGIT HEXDIGIT -> blue
83+
;; ESCAPED-CHARACTER := #\\ any-character
84+
;; HEXCOLOR-PREFIX := #\#
85+
;; HEX-DIGIT := (and (character-ranges #\0 #\9)
86+
;; (character-ranges #\a #\f)
87+
;; (character-ranges #\A #\f)
88+
;; DIGIT := (character-ranges #\0 #\9)
89+
;; ATTRIBUTE-VALUE := "bold"
90+
;; | "italic"
91+
;; | "underline"
92+
;; | "blink"
93+
;; COLOR-NAME := "black"
94+
;; | "red"
95+
;; | "green"
96+
;; | "yellow"
97+
;; | "blue"
98+
;; | "magenta"
99+
;; | "cyan"
100+
;; | "white"
99101

100102
(define-constant +conf-filename+ "main.conf" :test #'string=)
101103

@@ -272,6 +274,9 @@
272274
(defrule ignore-user-boost-re-key "ignore-user-boost-regexp"
273275
(:constant :ignore-user-boost-re))
274276

277+
(defrule ignore-tag-re-assign "ignore-tag-regexp"
278+
(:constant :ignore-tag-re))
279+
275280
(defrule ignore-user-re-assign
276281
(and ignore-user-re-key blanks
277282
assign blanks regexp blanks)
@@ -439,6 +444,7 @@
439444
color-re-assign
440445
ignore-user-re-assign
441446
ignore-user-boost-re-assign
447+
ignore-tag-re-assign
442448
server-assign
443449
username-assign
444450
open-link-helper
@@ -622,6 +628,7 @@
622628
color-re
623629
ignore-user-re
624630
ignore-user-boost-re
631+
ignore-tag-re
625632
post-allowed-language
626633
purge-history-days-offset
627634
purge-cache-days-offset
@@ -644,6 +651,7 @@
644651
((or (eq +key-color-re+ key)
645652
(eq +key-ignore-user-re+ key)
646653
(eq +key-ignore-user-boost-re+ key)
654+
(eq +key-ignore-tag-re+ key)
647655
(eq +key-open-link-helper+ key)
648656
(eq +key-post-allowed-language+ key))
649657
(setf (access:accesses *software-configuration* key)
@@ -967,6 +975,10 @@
967975
(access:accesses *software-configuration*
968976
+key-ignore-user-boost-re+))
969977

978+
(defun ignore-tag-regexps ()
979+
(access:accesses *software-configuration*
980+
+key-ignore-tag-re+))
981+
970982
(defmacro gen-win-key-access (fn-suffix key)
971983
`(defun ,(misc:format-fn-symbol t "win-~a" fn-suffix) (win-key)
972984
(access:accesses *software-configuration*

0 commit comments

Comments
 (0)