cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- initial commit.

This commit is contained in:
cage 2020-05-08 15:45:43 +02:00
commit c56a5b86ca
112 changed files with 42505 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
.gitignore vendored Normal file
View File

@ -0,0 +1,33 @@
Makefile
Makefile.in
autom4te.cache/
po/Makefile
po/Makefile.in
po/POTFILES
po/en@boldquot.gmo
po/en@boldquot.insert-header
po/en@boldquot.po
po/en@quot.gmo
po/en@quot.insert-header
po/en@quot.po
po/remove-potcdate.sed
po/stamp-po
po/it/
po/*.gmo
quick_quicklisp.sh
src/config.lisp
**-noshare.*
**~
*.diff
*.patch
*.log
tinmop

44
CONTRIBUTING.org Normal file
View File

@ -0,0 +1,44 @@
* Contributing
There is always need for help, you can join the developer, sending
patches or translating the UI to your favourite language.
Also there is need for better documentation.
And a fancy logo would be great too! :)
Just point your browser to the
[[https://notabug.org/cage/tinmop/][code repository]].
** Some Notes
Please understand that tinmop is a very opinionated client and with a
someway radical approach to social networks. The developer tried to
offer a "/degamified/" experience to the user.
This means that, in particular, i will not accept patches or
requests for:
- implementing mentioning or other alerts system;
- trending, hashtags/people suggested, etc.;
- count of followers, people you are following.
I think you get the idea ;-)
Also i try to hide as much as information i can to the server so i
won't implement muting or blocking. Ignore the toot for annoying user
configuring the client to do so, instead.
Finally before starting coding like a crazy it is better to discuss
the general idea with the developers, this way will be more unlikely
that the patch will be rejected and our time wasted.
And do not forget to have fun!
* Translations
translation template can be found in ~po/tinmop.pot~ in gettext format,
there are a bunch of free software editor to work with this file or
you can just
[[https://www.gnu.org/software/gettext/manual/html_node/PO-Mode.html][use emacs]].
So far the only completed translation is in Italian.

674
COPYING Normal file
View File

@ -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:
<program> Copyright (C) <year> <name of author>
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>.

6
ChangeLog Normal file
View File

@ -0,0 +1,6 @@
2019-12-26 gettextize <bug-gnu-gettext@gnu.org>
* Makefile.am (SUBDIRS): Add po.
(EXTRA_DIST): Add config.rpath, m4/ChangeLog.
* configure.ac (AC_CONFIG_FILES): Add po/Makefile.in.

263
LICENSES.org Normal file
View File

@ -0,0 +1,263 @@
- src/hooks
derived from
Copyright (c) 2014 Paul M. Rodriguez
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.
according to: https://github.com/TBRSS/serapeum
- src/db-utils.lisp
src/db.lisp
src/text-utils.lisp
uses code from:
niccolo': a chemicals inventory
Copyright (C) 2016 Universita' degli Studi di Palermo
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, 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/>.
- src/misc-utils.lisp
'defalias' derived from
Copyright (c) 2014 Paul M. Rodriguez
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.
according to: https://github.com/TBRSS/serapeum
'unsplice' derived from
Copyright (c) 2011-2012, James M. Lawrence. All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of the project nor the names of its
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
according to: https://github.com/lmj/lparallel
'intersperse' family of functions derives from serapeum
Copyright (c) 2014 Paul M. Rodriguez
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.
defun-w-lock
uses code from:
niccolo': a chemicals inventory
Copyright (C) 2016 Universita' degli Studi di Palermo
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, 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/>.
array-slice
derived from alexandria
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 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.
- misc.lisp uses code derived from:
local-time Copyright (c) 2005-2012 by Daniel Lowe
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.
- src/complete.lisp
derived from linedit
Copyright (c) 2003, 2004 Nikodemus Siivola, Julian Squires
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.
- src/windows.lisp
uses code from croatoan
Copyright (c) 2012-2019,2020 Anton Vidovic <anton.vidovic@gmx.de>
Portions Copyright (c) 2018 Daniel Vedder <d.vedder@web.de>
Portions Copyright (c) 2019 D4ryus <d4ryus@teknik.io>
Portions Copyright (c) 2019-2020 cage2 <github.com/cage2>
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.
- emoji-shortcodes.lisp
derived from:
https://github.com/milesj/emojibase
relased under
MIT License
Copyright (c) 2017-2019 Miles Johnson
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.

68
Makefile.am Normal file
View File

@ -0,0 +1,68 @@
# tinmop: an humble mastodon client
# Copyright (C) 2020 cage
# 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/][http://www.gnu.org/licenses/]].
ACLOCAL_AMFLAGS = -I m4
bin_SCRIPTS = tinmop
CLEANFILES = $(bin_SCRIPTS) $(CONF_PATH_FILE);
CONF_PATH_FILE = src/config.lisp
CONF_PATH_FILE_IN = src/config.lisp.in
BUILT_SOURCES = $(CONF_PATH_FILE)
EXTRA_DIST = config.rpath m4/ChangeLog tinmop.asd README.org src LICENSES.org COPYING \
etc/shared.conf etc/default-theme.conf etc/init.lisp
SUBDIRS = po
dist_doc_DATA = README.org README.txt LICENSES.org CONTRIBUTING.org doc/man.org doc/send-toot.lisp
nobase_dist_sysconf_DATA = etc/shared.conf etc/init.lisp etc/default-theme.conf
dist_man1_MANS = doc/tinmop.man
$(PACKAGE): $(CONF_PATH_FILE)
$(LISP_COMPILER) \
--eval "(asdf:load-system '$(PACKAGE))" \
--eval "(in-package main)" \
--eval "(sb-ext:save-lisp-and-die \"$(PACKAGE)\" :toplevel 'main::main :executable t :purify t :save-runtime-options t)"
$(CONF_PATH_FILE):
grep "^;" $(CONF_PATH_FILE_IN) > $(CONF_PATH_FILE)
echo -e "(in-package :config)\n" >> $(CONF_PATH_FILE);
echo "(alexandria:define-constant +sys-data-dir+" >> $(CONF_PATH_FILE);
echo -e "\""$(pkgdatadir)"/data/\" :test #'string=)\n" >> $(CONF_PATH_FILE);
echo "(alexandria:define-constant +sys-conf-dir+" >> $(CONF_PATH_FILE);
echo -e "\"$(sysconfdir)\" :test #'string=)\n" >> $(CONF_PATH_FILE);
echo "(alexandria:define-constant +catalog-dir+" >> $(CONF_PATH_FILE);
echo -e "\""$(localedir)"\" :test #'string=)\n" >> $(CONF_PATH_FILE);
echo "(alexandria:define-constant +text-domain+" >> $(CONF_PATH_FILE);
echo -e "\""$(PACKAGE)"\" :test #'string=)\n" >> $(CONF_PATH_FILE);
echo "(alexandria:define-constant +program-name+" >> $(CONF_PATH_FILE);
echo -e "\""$(PACKAGE)"\" :test #'string=)\n" >> $(CONF_PATH_FILE);
echo "(alexandria:define-constant +program-version+" >> $(CONF_PATH_FILE);
echo -e "\""$(VERSION)"\" :test #'string=)\n" >> $(CONF_PATH_FILE);
cat $(CONF_PATH_FILE).in | sed "\/^;;.*$\/d" >> $(CONF_PATH_FILE);

206
README.org Normal file
View File

@ -0,0 +1,206 @@
#+OPTIONS: html-postamble:nil html-preamble:nil
#+AUTHOR:
#+TITLE: tinmop
* Introduction
Tinmop is an opinionated client for Mastodon (or Pleroma using the
mastodon API). It offer a distraction free terminal interface.
The name is a recursive acronym: "Tinmop Is Not Mutt or Pine". The
older of us can remember that, in turn, Pine is an acronym as well:
"Pine Is Not Elm" and, finally, Elm means (according to Wikipedia):
"Electronic Mail".
* Peculiar Features
- tree structure of messages;
- subscriptions of hashtag;
- encrypted direct message (but see [[FAQ]]);
- no mentions notification, no knowlege of when or who favourited
your status;
- No blocking or muting, the client can be configured to ignore
a list of accounts.
* Dependency
** Programs
+ for running the program:
- SBCL compiler;
- xdg-open;
- your favourite editor (default: nano).
+ to install the package, including running the script to install
lisp libraries (~quick_quicklisp.sh~):
- GNU AWK (Gawk);
- BASH shell.
** Lisp Libraries
- alexandria;
- cl-ppcre;
- tooter;
- croatoan;
- osicat;
- cl-spark;
- access;
- sqlite;
- sxql;
- sxql-composer;
- marshal;
- bordeaux-threads;
- log4cl;
- local-time;
- cl-colors2;
- cl-i18n;
- clunit2;
- esrap;
- ieee-floats;
- parse-number;
- cl-html5-parser;
- unix-opts;
- crypto-shortcuts;
- drakma.
** Foreign (C language) library
- libssl
* Install
1. optional step needed only if you have not already the configure script,
you will need ~autotools~ for that.
#+BEGIN_SRC sh
$ autoreconf -fiv
#+END_SRC
2. run ~configure~ and resolve the missing dependencies (if any)
#+BEGIN_SRC sh
$ ./configure
#+END_SRC
3. the script ~quick-quicklisp.sh~ will download and install the library manager and the
library on your home dir.
#+BEGIN_SRC sh
$ ./quick_quicklisp.sh
#+END_SRC
This step is optional if you have already installed quicklisp, in
this case just load the [[Dependency][dependencies]]
using the client installed on your computer.
4. clone in ~$HOME/quicklisp/local-projects/~ the latest version of
tooter, a library to access mastodon API.
This step is temporary as this version will get into quicklisp eventually.
#+BEGIN_SRC sh
$ cd $HOME/quicklisp/local-projects/
$ git clone https://github.com/Shinmera/tooter.git
#+END_SRC
5. build the executable:
#+BEGIN_SRC sh
$ make
#+END_SRC
6. install on your system:
#+BEGIN_SRC sh
$ make install
#+END_SRC
7. run the software!
#+BEGIN_SRC sh
$ tinmop
#+END_SRC
* Usage
See the command line options:
#+BEGIN_SRC sh
$ tinmop -h
#+END_SRC
To get instruction about configuration:
#+BEGIN_SRC sh
$ man tinmop
#+END_SRC
* BUGS
Please file bug reports on the
[[https://notabug.org/cage/tinmop/][notabug repository]].
* Translations
Only Italian translation is regularly updated.
* License
This program is released under GNU General Public license version 3
or later (see COPYING file).
The program use data and code from other sources, please see
LICENSES.org for credits.
Although any efforts has been put to make the list of credits
exhaustive, errors are always possible. Please send correction to
cage-dev at twistfold dot it.
* Privacy
This software does collect nothing from its users in places
different from their local computer.
But launching ~quick_quicklisp.sh~ will contact
[[https://www.quicklisp.org/]], check the
[[https://beta.quicklisp.org/quicklisp.lisp][quicklisp sources]] for
details.
* Contributing
Any help is appreciated. If you intend to contribute please point
your browser to the
[[https://notabug.org/cage/tinmop/issues][issue tracker]] or file a
[[https://notabug.org/cage/tinmop/pulls][pull request]].
But, please take a minute to read the file [[./CONTRIBUTING.org]]
* FAQ
- are the encrypted messages secure?
No. First only a symmetric encryption scheme is implemented (so
there is a problem of secure key exchanging). Moreover i am not a
crypto expert and probably i made something wrong. Note that i am
not claiming that the algorithm (AES256) or the implementation of
such encrypting algorithm is flawed but that, likely, is flawed
the code i wrote to use the crypto library in this software.
So, please do not consider the encrypted message secure at all.
* NO WARRANTY
tinmop: an humble mastodon client
Copyright (C) 2020 cage
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/][http://www.gnu.org/licenses/]].

271
README.txt Normal file
View File

@ -0,0 +1,271 @@
━━━━━━━━
TINMOP
━━━━━━━━
Table of Contents
─────────────────
1. Introduction
2. Peculiar Features
3. Dependency
.. 1. Programs
.. 2. Lisp Libraries
.. 3. Foreign (C language) library
4. Install
5. Usage
6. BUGS
7. Translations
8. License
9. Privacy
10. Contributing
11. FAQ
12. NO WARRANTY
1 Introduction
══════════════
Tinmop is an opinionated client for Mastodon (or Pleroma using the
mastodon API). It offer a distraction free terminal interface.
The name is a recursive acronym: "Tinmop Is Not Mutt or Pine". The
older of us can remember that, in turn, Pine is an acronym as well:
"Pine Is Not Elm" and, finally, Elm means (according to Wikipedia):
"Electronic Mail".
2 Peculiar Features
═══════════════════
• tree structure of messages;
• subscriptions of hashtag;
• encrypted direct message (but see 11);
• no mentions notification, no knowlege of when or who favourited your
status;
• No blocking or muting, the client can be configured to ignore a list
of accounts.
3 Dependency
════════════
3.1 Programs
────────────
⁃ for running the program:
• SBCL compiler;
• xdg-open;
• your favourite editor (default: nano).
⁃ to install the package, including running the script to install lisp
libraries (`quick_quicklisp.sh'):
• GNU AWK (Gawk);
• BASH shell.
3.2 Lisp Libraries
──────────────────
• alexandria;
• cl-ppcre;
• tooter;
• croatoan;
• osicat;
• cl-spark;
• access;
• sqlite;
• sxql;
• sxql-composer;
• marshal;
• bordeaux-threads;
• log4cl;
• local-time;
• cl-colors2;
• cl-i18n;
• clunit2;
• esrap;
• ieee-floats;
• parse-number;
• cl-html5-parser;
• unix-opts;
• crypto-shortcuts;
• drakma.
3.3 Foreign (C language) library
────────────────────────────────
• libssl
4 Install
═════════
1. optional step needed only if you have not already the configure
script, you will need `autotools' for that.
┌────
│ $ autoreconf -fiv
└────
2. run `configure' and resolve the missing dependencies (if any)
┌────
│ $ ./configure
└────
3. the script `quick-quicklisp.sh' will download and install the
library manager and the library on your home dir.
┌────
│ $ ./quick_quicklisp.sh
└────
This step is optional if you have already installed quicklisp, in
this case just load the [dependencies] using the client installed
on your computer.
4. clone in `$HOME/quicklisp/local-projects/' the latest version of
tooter, a library to access mastodon API.
This step is temporary as this version will get into quicklisp
eventually.
┌────
│ $ cd $HOME/quicklisp/local-projects/
│ $ git clone https://github.com/Shinmera/tooter.git
└────
5. build the executable:
┌────
│ $ make
└────
6. install on your system:
┌────
│ $ make install
└────
7. run the software!
┌────
│ $ tinmop
└────
[dependencies] See section 3
5 Usage
═══════
See the command line options:
┌────
│ $ tinmop -h
└────
To get instruction about configuration:
┌────
│ $ man tinmop
└────
6 BUGS
══════
Please file bug reports on the [notabug repository].
[notabug repository] <https://notabug.org/cage/tinmop/>
7 Translations
══════════════
Only Italian translation is regularly updated.
8 License
═════════
This program is released under GNU General Public license version 3 or
later (see COPYING file).
The program use data and code from other sources, please see
LICENSES.org for credits.
Although any efforts has been put to make the list of credits
exhaustive, errors are always possible. Please send correction to
cage-dev at twistfold dot it.
9 Privacy
═════════
This software does collect nothing from its users in places different
from their local computer.
But launching `quick_quicklisp.sh' will contact
<https://www.quicklisp.org/>, check the [quicklisp sources] for
details.
[quicklisp sources] <https://beta.quicklisp.org/quicklisp.lisp>
10 Contributing
═══════════════
Any help is appreciated. If you intend to contribute please point your
browser to the [issue tracker] or file a [pull request].
But, please take a minute to read the file <file:./CONTRIBUTING.org>
[issue tracker] <https://notabug.org/cage/tinmop/issues>
[pull request] <https://notabug.org/cage/tinmop/pulls>
11 FAQ
══════
• are the encrypted messages secure?
No. First only a symmetric encryption scheme is implemented (so
there is a problem of secure key exchanging). Moreover i am not a
crypto expert and probably i made something wrong. Note that i am
not claiming that the algorithm (AES256) or the implementation of
such encrypting algorithm is flawed but that, likely, is flawed the
code i wrote to use the crypto library in this software.
So, please do not consider the encrypted message secure at all.
12 NO WARRANTY
══════════════
tinmop: an humble mastodon client Copyright (C) 2020 cage
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/].
[http://www.gnu.org/licenses/] <http://www.gnu.org/licenses/>

1202
aclocal.m4 vendored Normal file
View File

File diff suppressed because it is too large Load Diff

51
compare_version.awk Normal file
View File

@ -0,0 +1,51 @@
# tinmop: an humble mastodon client
# Copyright (C) 2020 cage
# 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/][http://www.gnu.org/licenses/]].
BEGIN {
TRUE = 1;
FALSE = 0;
VERSION_SEP = "\\.";
}
function split_version_number (version, parsed) {
split(version, parsed, VERSION_SEP);
for (i in parsed) {
parsed[i] = strtonum(parsed[i]);
}
}
function version_less_than_p (version_a, version_b, idx) {
for (idx=1; idx <= length(version_a); idx++){
if(version_a[idx] < version_b[idx]){
return TRUE;
} else if(version_a[idx] > version_b[idx]){
return FALSE;
}
}
return FALSE;
}
// {
versions[""]="";
version_a[""]="";
version_b[""]="";
split($0, versions, "[[:space:]]+");
split_version_number(versions[1], version_a);
split_version_number(versions[2], version_b);
print (version_less_than_p(version_a, version_b));
}

348
compile Executable file
View File

@ -0,0 +1,348 @@
#! /bin/sh
# Wrapper for compilers which do not understand '-c -o'.
scriptversion=2018-03-07.03; # UTC
# Copyright (C) 1999-2020 Free Software Foundation, Inc.
# Written by Tom Tromey <tromey@cygnus.com>.
#
# 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. If not, see <https://www.gnu.org/licenses/>.
# As a special exception to the GNU General Public License, if you
# distribute this file as part of a program that contains a
# configuration script generated by Autoconf, you may include it under
# the same distribution terms that you use for the rest of that program.
# This file is maintained in Automake, please report
# bugs to <bug-automake@gnu.org> or send patches to
# <automake-patches@gnu.org>.
nl='
'
# We need space, tab and new line, in precisely that order. Quoting is
# there to prevent tools from complaining about whitespace usage.
IFS=" "" $nl"
file_conv=
# func_file_conv build_file lazy
# Convert a $build file to $host form and store it in $file
# Currently only supports Windows hosts. If the determined conversion
# type is listed in (the comma separated) LAZY, no conversion will
# take place.
func_file_conv ()
{
file=$1
case $file in
/ | /[!/]*) # absolute file, and not a UNC file
if test -z "$file_conv"; then
# lazily determine how to convert abs files
case `uname -s` in
MINGW*)
file_conv=mingw
;;
CYGWIN* | MSYS*)
file_conv=cygwin
;;
*)
file_conv=wine
;;
esac
fi
case $file_conv/,$2, in
*,$file_conv,*)
;;
mingw/*)
file=`cmd //C echo "$file " | sed -e 's/"\(.*\) " *$/\1/'`
;;
cygwin/* | msys/*)
file=`cygpath -m "$file" || echo "$file"`
;;
wine/*)
file=`winepath -w "$file" || echo "$file"`
;;
esac
;;
esac
}
# func_cl_dashL linkdir
# Make cl look for libraries in LINKDIR
func_cl_dashL ()
{
func_file_conv "$1"
if test -z "$lib_path"; then
lib_path=$file
else
lib_path="$lib_path;$file"
fi
linker_opts="$linker_opts -LIBPATH:$file"
}
# func_cl_dashl library
# Do a library search-path lookup for cl
func_cl_dashl ()
{
lib=$1
found=no
save_IFS=$IFS
IFS=';'
for dir in $lib_path $LIB
do
IFS=$save_IFS
if $shared && test -f "$dir/$lib.dll.lib"; then
found=yes
lib=$dir/$lib.dll.lib
break
fi
if test -f "$dir/$lib.lib"; then
found=yes
lib=$dir/$lib.lib
break
fi
if test -f "$dir/lib$lib.a"; then
found=yes
lib=$dir/lib$lib.a
break
fi
done
IFS=$save_IFS
if test "$found" != yes; then
lib=$lib.lib
fi
}
# func_cl_wrapper cl arg...
# Adjust compile command to suit cl
func_cl_wrapper ()
{
# Assume a capable shell
lib_path=
shared=:
linker_opts=
for arg
do
if test -n "$eat"; then
eat=
else
case $1 in
-o)
# configure might choose to run compile as 'compile cc -o foo foo.c'.
eat=1
case $2 in
*.o | *.[oO][bB][jJ])
func_file_conv "$2"
set x "$@" -Fo"$file"
shift
;;
*)
func_file_conv "$2"
set x "$@" -Fe"$file"
shift
;;
esac
;;
-I)
eat=1
func_file_conv "$2" mingw
set x "$@" -I"$file"
shift
;;
-I*)
func_file_conv "${1#-I}" mingw
set x "$@" -I"$file"
shift
;;
-l)
eat=1
func_cl_dashl "$2"
set x "$@" "$lib"
shift
;;
-l*)
func_cl_dashl "${1#-l}"
set x "$@" "$lib"
shift
;;
-L)
eat=1
func_cl_dashL "$2"
;;
-L*)
func_cl_dashL "${1#-L}"
;;
-static)
shared=false
;;
-Wl,*)
arg=${1#-Wl,}
save_ifs="$IFS"; IFS=','
for flag in $arg; do
IFS="$save_ifs"
linker_opts="$linker_opts $flag"
done
IFS="$save_ifs"
;;
-Xlinker)
eat=1
linker_opts="$linker_opts $2"
;;
-*)
set x "$@" "$1"
shift
;;
*.cc | *.CC | *.cxx | *.CXX | *.[cC]++)
func_file_conv "$1"
set x "$@" -Tp"$file"
shift
;;
*.c | *.cpp | *.CPP | *.lib | *.LIB | *.Lib | *.OBJ | *.obj | *.[oO])
func_file_conv "$1" mingw
set x "$@" "$file"
shift
;;
*)
set x "$@" "$1"
shift
;;
esac
fi
shift
done
if test -n "$linker_opts"; then
linker_opts="-link$linker_opts"
fi
exec "$@" $linker_opts
exit 1
}
eat=
case $1 in
'')
echo "$0: No command. Try '$0 --help' for more information." 1>&2
exit 1;
;;
-h | --h*)
cat <<\EOF
Usage: compile [--help] [--version] PROGRAM [ARGS]
Wrapper for compilers which do not understand '-c -o'.
Remove '-o dest.o' from ARGS, run PROGRAM with the remaining
arguments, and rename the output as expected.
If you are trying to build a whole package this is not the
right script to run: please start by reading the file 'INSTALL'.
Report bugs to <bug-automake@gnu.org>.
EOF
exit $?
;;
-v | --v*)
echo "compile $scriptversion"
exit $?
;;
cl | *[/\\]cl | cl.exe | *[/\\]cl.exe | \
icl | *[/\\]icl | icl.exe | *[/\\]icl.exe )
func_cl_wrapper "$@" # Doesn't return...
;;
esac
ofile=
cfile=
for arg
do
if test -n "$eat"; then
eat=
else
case $1 in
-o)
# configure might choose to run compile as 'compile cc -o foo foo.c'.
# So we strip '-o arg' only if arg is an object.
eat=1
case $2 in
*.o | *.obj)
ofile=$2
;;
*)
set x "$@" -o "$2"
shift
;;
esac
;;
*.c)
cfile=$1
set x "$@" "$1"
shift
;;
*)
set x "$@" "$1"
shift
;;
esac
fi
shift
done
if test -z "$ofile" || test -z "$cfile"; then
# If no '-o' option was seen then we might have been invoked from a
# pattern rule where we don't need one. That is ok -- this is a
# normal compilation that the losing compiler can handle. If no
# '.c' file was seen then we are probably linking. That is also
# ok.
exec "$@"
fi
# Name of file we expect compiler to create.
cofile=`echo "$cfile" | sed 's|^.*[\\/]||; s|^[a-zA-Z]:||; s/\.c$/.o/'`
# Create the lock directory.
# Note: use '[/\\:.-]' here to ensure that we don't use the same name
# that we are using for the .o file. Also, base the name on the expected
# object file name, since that is what matters with a parallel build.
lockdir=`echo "$cofile" | sed -e 's|[/\\:.-]|_|g'`.d
while true; do
if mkdir "$lockdir" >/dev/null 2>&1; then
break
fi
sleep 1
done
# FIXME: race condition here if user kills between mkdir and trap.
trap "rmdir '$lockdir'; exit 1" 1 2 15
# Run the compile.
"$@"
ret=$?
if test -f "$cofile"; then
test "$cofile" = "$ofile" || mv "$cofile" "$ofile"
elif test -f "${cofile}bj"; then
test "${cofile}bj" = "$ofile" || mv "${cofile}bj" "$ofile"
fi
rmdir "$lockdir"
exit $ret
# Local Variables:
# mode: shell-script
# sh-indentation: 2
# eval: (add-hook 'before-save-hook 'time-stamp)
# time-stamp-start: "scriptversion="
# time-stamp-format: "%:y-%02m-%02d.%02H"
# time-stamp-time-zone: "UTC0"
# time-stamp-end: "; # UTC"
# End:

1480
config.guess vendored Executable file
View File

File diff suppressed because it is too large Load Diff

684
config.rpath Executable file
View File

@ -0,0 +1,684 @@
#! /bin/sh
# Output a system dependent set of variables, describing how to set the
# run time search path of shared libraries in an executable.
#
# Copyright 1996-2016 Free Software Foundation, Inc.
# Taken from GNU libtool, 2001
# Originally by Gordon Matzigkeit <gord@gnu.ai.mit.edu>, 1996
#
# This file is free software; the Free Software Foundation gives
# unlimited permission to copy and/or distribute it, with or without
# modifications, as long as this notice is preserved.
#
# The first argument passed to this file is the canonical host specification,
# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM
# or
# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM
# The environment variables CC, GCC, LDFLAGS, LD, with_gnu_ld
# should be set by the caller.
#
# The set of defined variables is at the end of this script.
# Known limitations:
# - On IRIX 6.5 with CC="cc", the run time search patch must not be longer
# than 256 bytes, otherwise the compiler driver will dump core. The only
# known workaround is to choose shorter directory names for the build
# directory and/or the installation directory.
# All known linkers require a '.a' archive for static linking (except MSVC,
# which needs '.lib').
libext=a
shrext=.so
host="$1"
host_cpu=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'`
host_vendor=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'`
host_os=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'`
# Code taken from libtool.m4's _LT_CC_BASENAME.
for cc_temp in $CC""; do
case $cc_temp in
compile | *[\\/]compile | ccache | *[\\/]ccache ) ;;
distcc | *[\\/]distcc | purify | *[\\/]purify ) ;;
\-*) ;;
*) break;;
esac
done
cc_basename=`echo "$cc_temp" | sed -e 's%^.*/%%'`
# Code taken from libtool.m4's _LT_COMPILER_PIC.
wl=
if test "$GCC" = yes; then
wl='-Wl,'
else
case "$host_os" in
aix*)
wl='-Wl,'
;;
mingw* | cygwin* | pw32* | os2* | cegcc*)
;;
hpux9* | hpux10* | hpux11*)
wl='-Wl,'
;;
irix5* | irix6* | nonstopux*)
wl='-Wl,'
;;
linux* | k*bsd*-gnu | kopensolaris*-gnu)
case $cc_basename in
ecc*)
wl='-Wl,'
;;
icc* | ifort*)
wl='-Wl,'
;;
lf95*)
wl='-Wl,'
;;
nagfor*)
wl='-Wl,-Wl,,'
;;
pgcc* | pgf77* | pgf90* | pgf95* | pgfortran*)
wl='-Wl,'
;;
ccc*)
wl='-Wl,'
;;
xl* | bgxl* | bgf* | mpixl*)
wl='-Wl,'
;;
como)
wl='-lopt='
;;
*)
case `$CC -V 2>&1 | sed 5q` in
*Sun\ F* | *Sun*Fortran*)
wl=
;;
*Sun\ C*)
wl='-Wl,'
;;
esac
;;
esac
;;
newsos6)
;;
*nto* | *qnx*)
;;
osf3* | osf4* | osf5*)
wl='-Wl,'
;;
rdos*)
;;
solaris*)
case $cc_basename in
f77* | f90* | f95* | sunf77* | sunf90* | sunf95*)
wl='-Qoption ld '
;;
*)
wl='-Wl,'
;;
esac
;;
sunos4*)
wl='-Qoption ld '
;;
sysv4 | sysv4.2uw2* | sysv4.3*)
wl='-Wl,'
;;
sysv4*MP*)
;;
sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*)
wl='-Wl,'
;;
unicos*)
wl='-Wl,'
;;
uts4*)
;;
esac
fi
# Code taken from libtool.m4's _LT_LINKER_SHLIBS.
hardcode_libdir_flag_spec=
hardcode_libdir_separator=
hardcode_direct=no
hardcode_minus_L=no
case "$host_os" in
cygwin* | mingw* | pw32* | cegcc*)
# FIXME: the MSVC++ port hasn't been tested in a loooong time
# When not using gcc, we currently assume that we are using
# Microsoft Visual C++.
if test "$GCC" != yes; then
with_gnu_ld=no
fi
;;
interix*)
# we just hope/assume this is gcc and not c89 (= MSVC++)
with_gnu_ld=yes
;;
openbsd*)
with_gnu_ld=no
;;
esac
ld_shlibs=yes
if test "$with_gnu_ld" = yes; then
# Set some defaults for GNU ld with shared library support. These
# are reset later if shared libraries are not supported. Putting them
# here allows them to be overridden if necessary.
# Unlike libtool, we use -rpath here, not --rpath, since the documented
# option of GNU ld is called -rpath, not --rpath.
hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
case "$host_os" in
aix[3-9]*)
# On AIX/PPC, the GNU linker is very broken
if test "$host_cpu" != ia64; then
ld_shlibs=no
fi
;;
amigaos*)
case "$host_cpu" in
powerpc)
;;
m68k)
hardcode_libdir_flag_spec='-L$libdir'
hardcode_minus_L=yes
;;
esac
;;
beos*)
if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
:
else
ld_shlibs=no
fi
;;
cygwin* | mingw* | pw32* | cegcc*)
# hardcode_libdir_flag_spec is actually meaningless, as there is
# no search path for DLLs.
hardcode_libdir_flag_spec='-L$libdir'
if $LD --help 2>&1 | grep 'auto-import' > /dev/null; then
:
else
ld_shlibs=no
fi
;;
haiku*)
;;
interix[3-9]*)
hardcode_direct=no
hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
;;
gnu* | linux* | tpf* | k*bsd*-gnu | kopensolaris*-gnu)
if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
:
else
ld_shlibs=no
fi
;;
netbsd*)
;;
solaris*)
if $LD -v 2>&1 | grep 'BFD 2\.8' > /dev/null; then
ld_shlibs=no
elif $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
:
else
ld_shlibs=no
fi
;;
sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX*)
case `$LD -v 2>&1` in
*\ [01].* | *\ 2.[0-9].* | *\ 2.1[0-5].*)
ld_shlibs=no
;;
*)
if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
hardcode_libdir_flag_spec='`test -z "$SCOABSPATH" && echo ${wl}-rpath,$libdir`'
else
ld_shlibs=no
fi
;;
esac
;;
sunos4*)
hardcode_direct=yes
;;
*)
if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
:
else
ld_shlibs=no
fi
;;
esac
if test "$ld_shlibs" = no; then
hardcode_libdir_flag_spec=
fi
else
case "$host_os" in
aix3*)
# Note: this linker hardcodes the directories in LIBPATH if there
# are no directories specified by -L.
hardcode_minus_L=yes
if test "$GCC" = yes; then
# Neither direct hardcoding nor static linking is supported with a
# broken collect2.
hardcode_direct=unsupported
fi
;;
aix[4-9]*)
if test "$host_cpu" = ia64; then
# On IA64, the linker does run time linking by default, so we don't
# have to do anything special.
aix_use_runtimelinking=no
else
aix_use_runtimelinking=no
# Test if we are trying to use run time linking or normal
# AIX style linking. If -brtl is somewhere in LDFLAGS, we
# need to do runtime linking.
case $host_os in aix4.[23]|aix4.[23].*|aix[5-9]*)
for ld_flag in $LDFLAGS; do
if (test $ld_flag = "-brtl" || test $ld_flag = "-Wl,-brtl"); then
aix_use_runtimelinking=yes
break
fi
done
;;
esac
fi
hardcode_direct=yes
hardcode_libdir_separator=':'
if test "$GCC" = yes; then
case $host_os in aix4.[012]|aix4.[012].*)
collect2name=`${CC} -print-prog-name=collect2`
if test -f "$collect2name" && \
strings "$collect2name" | grep resolve_lib_name >/dev/null
then
# We have reworked collect2
:
else
# We have old collect2
hardcode_direct=unsupported
hardcode_minus_L=yes
hardcode_libdir_flag_spec='-L$libdir'
hardcode_libdir_separator=
fi
;;
esac
fi
# Begin _LT_AC_SYS_LIBPATH_AIX.
echo 'int main () { return 0; }' > conftest.c
${CC} ${LDFLAGS} conftest.c -o conftest
aix_libpath=`dump -H conftest 2>/dev/null | sed -n -e '/Import File Strings/,/^$/ { /^0/ { s/^0 *\(.*\)$/\1/; p; }
}'`
if test -z "$aix_libpath"; then
aix_libpath=`dump -HX64 conftest 2>/dev/null | sed -n -e '/Import File Strings/,/^$/ { /^0/ { s/^0 *\(.*\)$/\1/; p; }
}'`
fi
if test -z "$aix_libpath"; then
aix_libpath="/usr/lib:/lib"
fi
rm -f conftest.c conftest
# End _LT_AC_SYS_LIBPATH_AIX.
if test "$aix_use_runtimelinking" = yes; then
hardcode_libdir_flag_spec='${wl}-blibpath:$libdir:'"$aix_libpath"
else
if test "$host_cpu" = ia64; then
hardcode_libdir_flag_spec='${wl}-R $libdir:/usr/lib:/lib'
else
hardcode_libdir_flag_spec='${wl}-blibpath:$libdir:'"$aix_libpath"
fi
fi
;;
amigaos*)
case "$host_cpu" in
powerpc)
;;
m68k)
hardcode_libdir_flag_spec='-L$libdir'
hardcode_minus_L=yes
;;
esac
;;
bsdi[45]*)
;;
cygwin* | mingw* | pw32* | cegcc*)
# When not using gcc, we currently assume that we are using
# Microsoft Visual C++.
# hardcode_libdir_flag_spec is actually meaningless, as there is
# no search path for DLLs.
hardcode_libdir_flag_spec=' '
libext=lib
;;
darwin* | rhapsody*)
hardcode_direct=no
if { case $cc_basename in ifort*) true;; *) test "$GCC" = yes;; esac; }; then
:
else
ld_shlibs=no
fi
;;
dgux*)
hardcode_libdir_flag_spec='-L$libdir'
;;
freebsd2.[01]*)
hardcode_direct=yes
hardcode_minus_L=yes
;;
freebsd* | dragonfly*)
hardcode_libdir_flag_spec='-R$libdir'
hardcode_direct=yes
;;
hpux9*)
hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
hardcode_libdir_separator=:
hardcode_direct=yes
# hardcode_minus_L: Not really in the search PATH,
# but as the default location of the library.
hardcode_minus_L=yes
;;
hpux10*)
if test "$with_gnu_ld" = no; then
hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
hardcode_libdir_separator=:
hardcode_direct=yes
# hardcode_minus_L: Not really in the search PATH,
# but as the default location of the library.
hardcode_minus_L=yes
fi
;;
hpux11*)
if test "$with_gnu_ld" = no; then
hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
hardcode_libdir_separator=:
case $host_cpu in
hppa*64*|ia64*)
hardcode_direct=no
;;
*)
hardcode_direct=yes
# hardcode_minus_L: Not really in the search PATH,
# but as the default location of the library.
hardcode_minus_L=yes
;;
esac
fi
;;
irix5* | irix6* | nonstopux*)
hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
hardcode_libdir_separator=:
;;
netbsd*)
hardcode_libdir_flag_spec='-R$libdir'
hardcode_direct=yes
;;
newsos6)
hardcode_direct=yes
hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
hardcode_libdir_separator=:
;;
*nto* | *qnx*)
;;
openbsd*)
if test -f /usr/libexec/ld.so; then
hardcode_direct=yes
if test -z "`echo __ELF__ | $CC -E - | grep __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then
hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
else
case "$host_os" in
openbsd[01].* | openbsd2.[0-7] | openbsd2.[0-7].*)
hardcode_libdir_flag_spec='-R$libdir'
;;
*)
hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
;;
esac
fi
else
ld_shlibs=no
fi
;;
os2*)
hardcode_libdir_flag_spec='-L$libdir'
hardcode_minus_L=yes
;;
osf3*)
hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
hardcode_libdir_separator=:
;;
osf4* | osf5*)
if test "$GCC" = yes; then
hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
else
# Both cc and cxx compiler support -rpath directly
hardcode_libdir_flag_spec='-rpath $libdir'
fi
hardcode_libdir_separator=:
;;
solaris*)
hardcode_libdir_flag_spec='-R$libdir'
;;
sunos4*)
hardcode_libdir_flag_spec='-L$libdir'
hardcode_direct=yes
hardcode_minus_L=yes
;;
sysv4)
case $host_vendor in
sni)
hardcode_direct=yes # is this really true???
;;
siemens)
hardcode_direct=no
;;
motorola)
hardcode_direct=no #Motorola manual says yes, but my tests say they lie
;;
esac
;;
sysv4.3*)
;;
sysv4*MP*)
if test -d /usr/nec; then
ld_shlibs=yes
fi
;;
sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[01].[10]* | unixware7* | sco3.2v5.0.[024]*)
;;
sysv5* | sco3.2v5* | sco5v6*)
hardcode_libdir_flag_spec='`test -z "$SCOABSPATH" && echo ${wl}-R,$libdir`'
hardcode_libdir_separator=':'
;;
uts4*)
hardcode_libdir_flag_spec='-L$libdir'
;;
*)
ld_shlibs=no
;;
esac
fi
# Check dynamic linker characteristics
# Code taken from libtool.m4's _LT_SYS_DYNAMIC_LINKER.
# Unlike libtool.m4, here we don't care about _all_ names of the library, but
# only about the one the linker finds when passed -lNAME. This is the last
# element of library_names_spec in libtool.m4, or possibly two of them if the
# linker has special search rules.
library_names_spec= # the last element of library_names_spec in libtool.m4
libname_spec='lib$name'
case "$host_os" in
aix3*)
library_names_spec='$libname.a'
;;
aix[4-9]*)
library_names_spec='$libname$shrext'
;;
amigaos*)
case "$host_cpu" in
powerpc*)
library_names_spec='$libname$shrext' ;;
m68k)
library_names_spec='$libname.a' ;;
esac
;;
beos*)
library_names_spec='$libname$shrext'
;;
bsdi[45]*)
library_names_spec='$libname$shrext'
;;
cygwin* | mingw* | pw32* | cegcc*)
shrext=.dll
library_names_spec='$libname.dll.a $libname.lib'
;;
darwin* | rhapsody*)
shrext=.dylib
library_names_spec='$libname$shrext'
;;
dgux*)
library_names_spec='$libname$shrext'
;;
freebsd[23].*)
library_names_spec='$libname$shrext$versuffix'
;;
freebsd* | dragonfly*)
library_names_spec='$libname$shrext'
;;
gnu*)
library_names_spec='$libname$shrext'
;;
haiku*)
library_names_spec='$libname$shrext'
;;
hpux9* | hpux10* | hpux11*)
case $host_cpu in
ia64*)
shrext=.so
;;
hppa*64*)
shrext=.sl
;;
*)
shrext=.sl
;;
esac
library_names_spec='$libname$shrext'
;;
interix[3-9]*)
library_names_spec='$libname$shrext'
;;
irix5* | irix6* | nonstopux*)
library_names_spec='$libname$shrext'
case "$host_os" in
irix5* | nonstopux*)
libsuff= shlibsuff=
;;
*)
case $LD in
*-32|*"-32 "|*-melf32bsmip|*"-melf32bsmip ") libsuff= shlibsuff= ;;
*-n32|*"-n32 "|*-melf32bmipn32|*"-melf32bmipn32 ") libsuff=32 shlibsuff=N32 ;;
*-64|*"-64 "|*-melf64bmip|*"-melf64bmip ") libsuff=64 shlibsuff=64 ;;
*) libsuff= shlibsuff= ;;
esac
;;
esac
;;
linux*oldld* | linux*aout* | linux*coff*)
;;
linux* | k*bsd*-gnu | kopensolaris*-gnu)
library_names_spec='$libname$shrext'
;;
knetbsd*-gnu)
library_names_spec='$libname$shrext'
;;
netbsd*)
library_names_spec='$libname$shrext'
;;
newsos6)
library_names_spec='$libname$shrext'
;;
*nto* | *qnx*)
library_names_spec='$libname$shrext'
;;
openbsd*)
library_names_spec='$libname$shrext$versuffix'
;;
os2*)
libname_spec='$name'
shrext=.dll
library_names_spec='$libname.a'
;;
osf3* | osf4* | osf5*)
library_names_spec='$libname$shrext'
;;
rdos*)
;;
solaris*)
library_names_spec='$libname$shrext'
;;
sunos4*)
library_names_spec='$libname$shrext$versuffix'
;;
sysv4 | sysv4.3*)
library_names_spec='$libname$shrext'
;;
sysv4*MP*)
library_names_spec='$libname$shrext'
;;
sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*)
library_names_spec='$libname$shrext'
;;
tpf*)
library_names_spec='$libname$shrext'
;;
uts4*)
library_names_spec='$libname$shrext'
;;
esac
sed_quote_subst='s/\(["`$\\]\)/\\\1/g'
escaped_wl=`echo "X$wl" | sed -e 's/^X//' -e "$sed_quote_subst"`
shlibext=`echo "$shrext" | sed -e 's,^\.,,'`
escaped_libname_spec=`echo "X$libname_spec" | sed -e 's/^X//' -e "$sed_quote_subst"`
escaped_library_names_spec=`echo "X$library_names_spec" | sed -e 's/^X//' -e "$sed_quote_subst"`
escaped_hardcode_libdir_flag_spec=`echo "X$hardcode_libdir_flag_spec" | sed -e 's/^X//' -e "$sed_quote_subst"`
LC_ALL=C sed -e 's/^\([a-zA-Z0-9_]*\)=/acl_cv_\1=/' <<EOF
# How to pass a linker flag through the compiler.
wl="$escaped_wl"
# Static library suffix (normally "a").
libext="$libext"
# Shared library suffix (normally "so").
shlibext="$shlibext"
# Format of library name prefix.
libname_spec="$escaped_libname_spec"
# Library names that the linker finds when passed -lNAME.
library_names_spec="$escaped_library_names_spec"
# Flag to hardcode \$libdir into a binary during linking.
# This must work even if \$libdir does not exist.
hardcode_libdir_flag_spec="$escaped_hardcode_libdir_flag_spec"
# Whether we need a single -rpath flag with a separated argument.
hardcode_libdir_separator="$hardcode_libdir_separator"
# Set to yes if using DIR/libNAME.so during linking hardcodes DIR into the
# resulting binary.
hardcode_direct="$hardcode_direct"
# Set to yes if using the -LDIR flag during linking hardcodes DIR into the
# resulting binary.
hardcode_minus_L="$hardcode_minus_L"
EOF

1801
config.sub vendored Executable file
View File

File diff suppressed because it is too large Load Diff

7853
configure vendored Executable file
View File

File diff suppressed because it is too large Load Diff

79
configure.ac Normal file
View File

@ -0,0 +1,79 @@
dnl tinmop: an humble mastodon client
dnl Copyright (C) 2020 cage
dnl This program is free software: you can redistribute it and/or modify
dnl it under the terms of the GNU General Public License as published by
dnl the Free Software Foundation, either version 3 of the License, or
dnl (at your option) any later version.
dnl This program is distributed in the hope that it will be useful,
dnl but WITHOUT ANY WARRANTY; without even the implied warranty of
dnl MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
dnl GNU General Public License for more details.
dnl You should have received a copy of the GNU General Public License
dnl along with this program.
dnl If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]].
AC_INIT([tinmop],[0.0.1],[https://notabug.org/cage/tinmop/],[tinmop])
AM_INIT_AUTOMAKE([-Wall foreign])
AM_GNU_GETTEXT([external])
AC_PATH_PROG([LISP_COMPILER],[sbcl],[no])
if test "$LISP_COMPILER" = "no" ; then
AC_MSG_ERROR([Can not find SBCL, Common Lisp compiler.])
fi
AC_PATH_PROG([CURL],[curl],[no])
if test "$CURL" = "no" ; then
AC_MSG_ERROR([Can not find curl.])
exit 1;
fi
AC_PATH_PROG([GPG],[gpg],[no])
if test "$GPG" = "no" ; then
AC_MSG_ERROR([Can not find gpg, crypto software.])
exit 1;
fi
AC_PATH_PROG([BASH],[bash],[no])
if test "$BASH" = "no" ; then
AC_MSG_ERROR([Can not find bash shell.])
exit 1;
fi
AC_PATH_PROG([GAWK],[gawk],[no])
if test "$GAWK" = "no" ; then
AC_MSG_ERROR([Can not find GNU AWK (gawk).])
exit 1;
fi
AC_PATH_PROG([XDG_OPEN],[xdg-open],[no])
if test "$GAWK" = "no" ; then
AC_MSG_ERROR([Can not find xdg-open.])
exit 1;
fi
AC_PROG_MKDIR_P
dnl check sbcl version
SBCL_MIN_VERSION="1.5.9";
SBCL_VERSION=`${LISP_COMPILER} --version | ${GAWK} -- '// {print $2}'`
SBCL_VERSION_OK=`echo "$SBCL_VERSION $SBCL_MIN_VERSION" | awk -f compare_version.awk`
if test "$SBCL_VERSION_OK" = "1" ; then
AC_MSG_ERROR([Lisp compiler too old, $SBCL_MIN_VERSION is the oldest supported.])
exit 1;
fi
AC_CONFIG_FILES([Makefile quick_quicklisp.sh po/Makefile.in])
AC_OUTPUT

213
doc/man.org Normal file
View File

@ -0,0 +1,213 @@
#+TITLE: tinmop
* Name
tinmop - a client for mastodon or pleroma social network
* Synopsis
tinmop [OPTION]...
* Description
This document assumes basic knowledge of how mastodon works. More
information about this topic can be found on the
official website ([[https://docs.joinmastodon.org/]]).
Tinmop propose a terminal interface to to connect with Mastodon or
Pleroma social network
* Options
Without options the program will start a terminal interface and will
try to connect to your instance (see [[Configuration]])
+ -e, --execute-script SCRIPT-FILE :: Execute a script file
+ -c, --check-follows-requests :: Checks for follow request at start
+ -u, --update-timeline :: Update the selected timeline
+ -t, --timeline TIMELINE-NAME :: Start using this timeline
+ -f, --folder FOLDER-NAME :: Start on that folder
+ -v, --version :: Print program version and exit
+ -h, --help :: print program help and exit
* Usage
Users of Tinmop are expected to interacts with the social network
using a terminal interface (TUI), The terminal screen layout is
sketched below:
#+NAME: screen-layout
#+BEGIN_SRC text
+---------------+---------------------------+
| | |
| tags window | thread windows |
| | |
| | modeline |
+---------------+---------------------------+
| | |
| conversations | message window |
| window | |
| | |
| | |
+---------------+---------------------------+
| command window |
+-------------------------------------------+
#+END_SRC
The screen is subdivided in five window:
- tag window :: shows the tag users subscribed for and available
messages for each tag;
- threads window :: for a given timeline and folder (see
[[Folders]]) show the discussions saved in user's local database;
- conversations window :: show the /private/ conversations the user is having with others;
- message window :: show the body of the message selected in the tag window
- command window :: the window where the user instruct the software to perform commands
The only way to interact with the program is using the keyboard.
There is a contextual help that appears when the user input data
that provide hints about commands and a quick help window that can
be shown by hitting ~?~ (if this keybinding has not been
customized).
** Folders
A folder is an object to groups messages for each timeline an
arbitrary number of folder can be created, when the last message of
a folder is deleted the folder is deleted as well.
* Configuration
The configuration of tinmop is based on text files but there are
available two different kind with different syntax and scope.
- a key-value text files used to configure the access credential to
server and visual theme of the program (simple configuration);
- common lisp source code. Used to write module (AKA plugin) and to
configure keybindings to interact with the software.
The distribution of this software comes with a bunch of pre-backed
configuration files but user is expected to write a simple file with
their credential to log into the server.
** Simple configuration
This is a simple file with each entry in a single line that look like this:
#+NAME: simple file example
#+BEGIN_SRC text
# a file can be included in another with this directive:
use "default-theme.conf"
# a line starting with a '#' is a comment
# The server instance name
server = server address
# your username
username = username
#+END_SRC
Not incidentally the information i the example above are the
absolute minimum the user has to provide before starts the program:
the name you chose when you made the account on the server and the
address of the server.
As you can see a line starting with a *#* is considered comment and
skipped by the program
The file with this credential are confidential and must be put into
user's home directory under the path
~/home/username/.local/share/tinmop/~. Probably the directory
~tinmop~ does not exists on user system, if it does not exists must
be created manually.
If the program was installed correctly two other files with simple
semantics are located in your system wide configuration directory
(usually ~/etc/tinmop/~), please check these files for more
information, as are extensively commented.
** Lisp program
These files contains Common lisp (see [[https://common-lisp.net/]])
source code. And are used both as a way to configure the program
and to write module for tinmop itself.
These files are the only way to configure program's keybindings:
sequence of pressing button to fire command commands (do not worry
it is not too difficult!).
These files must be a valid Common Lisp program to allow the
program to even starts. Again this is actual source code that is
loaded end executed by the main program; be careful, do not copy
and paste code from untrusted sources as this could results in a
*severe* security damage.
Again in the configuration directory there is a (commented) file
named ~init.lisp~ that user can use as their starting point to
write their files. A custom init file (or other module files must
be located into the directory ~$HOME/.local/share/tinmop/~
to be successfully loaded.
However there is no need to write their own init file if user is
happy with the provided one by the package maintainers.
* First time start
After the configuration the program can be started but we are not
ready to join the network yet because tinmop need to be /trusted/ by
the server. Just follows the instruction on screen to register the
application with your instance. This procedure should be followed
once: when the program starts for the first time (but please note
that there must be a file with valid credentials available).
* How to get more help
For help with mastodon visit the mastodon website.
The program has an inline help (default binding for help is "?")
Moreover you can have some useful hint at the program web page:
[https://www.autistici.org/interzona/tinmop/]
* BUGS
There are many, totally unknown, hiding in the code! Please help the
programmer to nail them using the
[[https://notabug.org/cage/tinmop/issues/][issue tracker]].
* Contributing
There is always need for help, you can join the developer, sending
patches or translating the UI to your favourite language.
Just point your browser to the
[[https://notabug.org/cage/tinmop/][code repository]].
See also the file CONTRIBUTE.org
* Privacy
This program do not interact with no other computer other than the
mastodon instance that the user configured.
If installed from the source note that the script
~quick_quicklisp.sh~ will contact [[https://www.quicklisp.org/]],
check the
[[https://beta.quicklisp.org/quicklisp.lisp][quicklisp sources]]
for details.
* Acknowledgment
My deep thanks to the folks that provided us with wonderful SBCL and
Common lisp libraries.
In particular i want to thanks the authors of the libraries Croatoan and Tooter
for their help when I started to develop this program.
There are more people i borrowed code and data from, they are mentioned
in the file LINCENSES.org

21
doc/send-toot.lisp Normal file
View File

@ -0,0 +1,21 @@
;; a comment starts with a semicolon like that
(in-package :scripts) ; always starts a script with this line
;; defun means 'define a function'
(defun read-stdin ()
;; 'let' introduce a new variable, 'data' in this case
(let ((data (loop ; read from standard and collect character in a list
for char = (read-char *standard-input* nil nil)
while char
collect char)))
(coerce data 'string))) ; transform the list in a string
(defun main ()
(when-let* ((body (read-stdin)))
;; the first element of a list (the stuff between parents is the
;; function name the rest of the lists are the functions parameters.
;; nil means false or kind of 'empty'
(send-status body nil nil nil +status-public-visibility+)))
;; call the function to send a toot
(main)

272
doc/tinmop.man Normal file
View File

@ -0,0 +1,272 @@
.TH "tinmop" "1"
.SH "Name"
.PP
tinmop - a client for mastodon or pleroma social network
.SH "Synopsis"
.PP
tinmop [OPTION]...
.SH "Description"
.PP
This document assumes basic knowledge of how mastodon works. More
information about this topic can be found on the
official website (\fIhttps://docs.joinmastodon.org/\fP).
.PP
Tinmop propose a terminal interface to to connect with Mastodon or
Pleroma social network
.SH "Options"
.PP
Without options the program will start a terminal interface and will
try to connect to your instance (see \fIConfiguration\fP)
.TP
\fB-e, --execute-script SCRIPT-FILE\fP
Execute a script file
.TP
\fB-c, --check-follows-requests \fP
Checks for follow request at start
.TP
\fB-u, --update-timeline \fP
Update the selected timeline
.TP
\fB-t, --timeline TIMELINE-NAME \fP
Start using this timeline
.TP
\fB-f, --folder FOLDER-NAME \fP
Start on that folder
.TP
\fB-v, --version \fP
Print program version and exit
.TP
\fB-h, --help \fP
print program help and exit
.SH "Usage"
.PP
Users of Tinmop are expected to interact with the social network
using a terminal interface (TUI), The terminal screen layout is
sketched below:
.RS
.nf
\fC+---------------+---------------------------+
| | |
| tags window | thread windows |
| | |
| | modeline |
+---------------+---------------------------+
| | |
| conversations | message window |
| window | |
| | |
| | |
+---------------+---------------------------+
| command window |
+-------------------------------------------+
\fP
.fi
.RE
.PP
The screen is subdivided in five window:
.TP
\fBtag window\fP
shows the tag users subscribed for and available
messages for each tag;
.TP
\fBthreads window\fP
for a given timeline and folder (see \fIFolders\fP) show
the discussions saved in user's local database;
.TP
\fBconversations window\fP
show the \fIprivate\fP conversations the user is having with others;
.TP
\fBmessage window\fP
show the body of the message selected in the tag window
.TP
\fBcommand window\fP
the window where the user instruct the software to perform commands
.PP
The only way to interact with the program is using the keyboard.
There is a contextual help that appears when the user input data
that provide hints about commands and a quick help window that can
be shown by hitting \fC?\fP (if this keybinding has not been
customized).
.SS "Folders"
.PP
A folder is an object to groups messages for each timeline an
arbitrary number of folder can be created, when the last message of
a folder is deleted the folder is deleted as well.
.SH "Configuration"
.PP
The configuration of tinmop is based on text files but there are
available two different kind with different syntax and scope.
.IP \(em 4
a key value text files used to configure the access credential to
.PP
server and visual theme of the program (simple configuration);
.IP \(em 4
common lisp source code. Used to write module (AKA plugin) and to
.PP
configure keybindings to interact with the software.
.PP
The distribution of this software comes with a bunch of pre-backed
configuration files but user is expected to write a simple file with
their credential to log into the server.
.SS "Simple configuration"
.PP
This is a simple file with each entry in a single line that look like this:
.RS
.nf
\fC
# a file can be included in another with this directive:
use "default-theme.conf"
# a line starting with a '#' is a comment
# The server instance name
server = server address
# your username
username = username
\fP
.fi
.RE
.PP
Not incidentally the information in the example above are the
absolute minimum the user has to provide before starts the program:
the name you chose when you made the account on the server and the
address of the server.
.PP
As you can see a line starting with a \fB#\fP is considered comment and
skipped by the program
.PP
The file with this credential are confidential and must be put into
user's home directory under the path
\fC/home/username/.local/share/tinmop/\fP. Probably the directory
\fCtinmop\fP does not exists on user system, if it does not exists must
be created manually.
.PP
If the program was installed correctly two other files with simple
semantics are located in your system wide configuration directory
(usually \fC/etc/tinmop/\fP), please check these files for more
information, as are extensively commented.
.SS "Lisp program"
.PP
These files contains Common lisp (see \fIhttps://common-lisp.net\fP)
source code. And are used both as a way to configure the program
and to write module for tinmop itself.
.PP
These files are the only way to configure program's keybindings:
sequence of pressing button to fire command commands (do not worry
it is not too difficult!).
.PP
These files must be a valid Common Lisp program to allow the
program to even starts. Again this is actual source code that is
loaded end executed by the main program; be careful, do not copy
and paste code from untrusted sources as this could results in a
\fBsevere\fP security damage.
.PP
Again in the configuration directory there is a (commented) file
named \fCinit.lisp\fP that user can use as their starting point to
write their files. A custom init file (or other module files must
be located into the directory \fC/home/username/.local/share/tinmop/\fP
to be successfully loaded.
.PP
However there is no need to write their own init file if user is
happy with the provided one by the package maintainers.
.SH "First time start"
.PP
After the configuration the program can be started but we are not
ready to join the network yet because tinmop need to be \fItrusted\fP by
the server. Just follows the instruction on screen to register the
application with your instance. This procedure should be followed
once. When the program starts for the first time (but please note
that there must be a file with valid credentials available).
.SH "Modules and scripts"
.PP
Users can write modules and scripts for tinmop, both are lisp
program so there is no artificial limiting to what they can do, the
only difference is that the script are loaded without the TUI so
they are useful for non interactive tasks.
.PP
An example of module is the distributed file \fCinit.lisp\fP and users
can find a simple script to send a toot in the their system wide
documentation directory (sometimes: \fC/usr/share/doc/\fP).
.SH "How to get more help"
.PP
For help with mastodon visit the mastodon website.
.PP
The program has an inline help (default binding for help is "?")
.PP
Moreover you can have some useful hint at the program web page:
.PP
\fIhttps://www.autistici.org/interzona/tinmop/\fP
.SH "BUGS"
.PP
There are many, totally unknown, hiding in the code! Please help the
programmer to nail them using the
https://notabug.org/cage/tinmop/issues/ \fBat\fP \fIissue tracker\fP.
.SH "Contributing"
.PP
There is always need for help, you can join the developer, sending
patches or translating the UI to your favourite language.
.PP
Just point your browser to the
https://notabug.org/cage/tinmop/ \fBat\fP \fIcode repository\fP.
.PP
See also the file CONTRIBUTE.org
.SH "Privacy"
.PP
This program do not interact with no other computer other than the
mastodon instance that the user configured.
.PP
If installed from the source note that the script
\fCquick_quicklisp.sh\fP will contact \fIhttps://www.quicklisp.org/\fP,
check the
https://beta.quicklisp.org/quicklisp.lisp \fBat\fP \fIquicklisp sources\fP
for details.
.SH "Acknowledgment"
.PP
See file LICENSES.org

418
etc/default-theme.conf Normal file
View File

@ -0,0 +1,418 @@
# this is the default theme for tinmop, feel free to customize it
# according to your taste , and do not forget to share! :)
# Note:
# valid color are specified using RGB triplets as #RRGGBB or color names
# valid color names are:
# - red
# - green
# - yellow
# - blue
# - magenta
# - cyan
# - white
#
# valid attributes are:
# - bold
# - italic
# - underline
# - blink
# The text that starts the title section of a window
window.title.left.stopper.value = "╼▌"
# The text taht end the title section of a window
window.title.right.stopper.value = "▐╾"
# default background color of terminal
main-window.background = black
# default foreground color (text) of terminal
main-window.foreground = white
# shown when a message was trasmitted in crypted form
crypted.mark.value = " 🔏👌"
# quick help window style
quick-help.header.foreground = white
quick-help.header.background = red
quick-help.header.attribute = bold
# help dialog style
help-dialog.background = white
help-dialog.foreground = red
# info dialog style
info-dialog.background = blue
info-dialog.foreground = yellow
# error dialog style
error-dialog.background = red
error-dialog.foreground = yellow
# input dialog style
input-dialog.background = blue
input-dialog.foreground = white
# this color specifies the style for form of the dialog
input-dialog.input.foreground = black
input-dialog.input.background = #aaaaaa
# this color specify the style for active form of the dialog
input-dialog.input.selected.foreground = black
input-dialog.input.selected.background = white
# the notify window shows useful information to the user
notify-window.background = #0219A2
notify-window.foreground = #55D67C
notify-window.life = 2
# a window shows this text in the top left corner to indicate that it
# has focus
window.focus.mark.value = "📌"
window.focus.mark.foreground = white
window.focus.mark.background = black
# this specify style for the thread window
thread-window.background = black
thread-window.foreground = blue
# the modeline window is a small section on the very bottom of the
# thread window that shows some information about the threads see
# below.
thread-window.modeline.background = blue
thread-window.modeline.foreground = yellow
# this variable customize the information that the modeline will
# shows, values prefixed with a '%' will be expanded, allowe values to
# be expanded are:
# - %u user account
# - %s server connected to
# - %k current timeline
# - %f current folder
# - %r number of read messages in this timeline/folder
# - %r number of total messages in this timeline/folder
# - %tags in selected messages (if any)
# - %% a percent sign
thread-window.modeline.value = "%u@%s ◈ %k %r/%t ◈ folder: %f ◈ tags: %h"
# this is the only width you have to specify as the others windows
# just fills the void left by this one
thread-window.width = 5/6
thread-window.height = 1/4
# colors for selected messages in thread window
thread-window.message.selected.background = cyan
thread-window.message.selected.foreground = black
#thread-window.message.selected.attribute = bold
# colors for messages marked for deletion in thread window
thread-window.message.deleted.background = red
thread-window.message.deleted.foreground = white
thread-window.message.deleted.attribute = bold
# colors for already read messages in thread window
thread-window.message.read.background = black
thread-window.message.read.foreground = #aaaaaa
thread-window.message.read.attribute = italic
# colors for new (not read) messages in thread window
thread-window.message.unread.background = black
thread-window.message.unread.foreground = cyan
#thread-window.message.unread.attribute = bold
# text to signal that you favourited this message
thread-window.message.favourite.value = "★"
# color of the text that signals that you favourited this message
thread-window.message.favourite.foreground = yellow
# text to signal that this message is marked as sensible
thread-window.message.sensitive.value = "⚠ "
# color of the text that signals that this message is marked as sensible
thread-window.message.sensitive.foreground = blue
# text that signals that you boosted this message
thread-window.message.boosted.value = "♻"
# color of the text that signals that you boosted this message
thread-window.message.boosted.foreground = cyan
# the messages are organized in trees
# color of the branch of the tree (the segments that connect messages)
thread-window.tree.branch.foreground = red
# color of the arrow in the tree that points to a single message
thread-window.tree.arrow.foreground = magenta
# color of the subject of the message (AKA sensistive text) for a
# message
thread-window.tree.data.foreground = white
# color of the subject of the message (AKA sensistive text) for
# message with no replies
thread-window.tree.data-leaf.foreground = white
# arrow that point to a message
thread-window.tree.arrow.value = "🞂 "
# segment that connect a message with no replies to the tree
thread-window.tree.leaf.value = "╰"
# segment that connect a message with replies to the tree
thread-window.tree.branch.value = "├"
# segment that push to the left a message subject
thread-window.tree.spacer.value = "─"
# vertical segment that connect tree branches
thread-window.tree.vertical-line.value = "│"
# a message shows the composition date, specify the format:
# values starting with '%' will be expanded, allowed values are:
# - %hour 0-23
# - %min
# - %second
# - %month numeric month
# - %year
# - %day day of the month
# - %weekday 0 to 7 (note: 0 is Sunday)
# - %short-weekday Sun to Mon
# - %long-weekday Sunday to Monday
# - %long-month Januray to December
# - %short-month Jan to Dec
# - %% a percent sign
thread-window.date-format.value = "%year %short-month %day %hour:%min"
# the windows that shows tags subscriptions
tags-window.height = 1/2
tags-window.background = black
tags-window.foreground = #67998B
# the colors for currently selected tags
tags-window.input.selected.background = black
tags-window.input.selected.foreground = #71AF8C
# tags shows a little histogram (note that some servers do not provide
# this information) for number of messages posted every day that
# contains this tag
tags-window.histogram.foreground = yellow
# test to indicate that this tags got new messages
tags-window.new-message.mark.value = " 📬"
# this is the window that shows active conversation (a conversation is
# active until the user chooses to ignore it)
conversations-window.background = black
conversations-window.foreground = #B48B21
# the colors for currently selected conversation
conversations-window.input.selected.background = #4B0301
conversations-window.input.selected.foreground = #B27DE5
#colors for count of read messages for conversation
#conversations-window.read.background = black
#conversations-window.read.foreground = blue
#colors for count of unreaded messages for conversation
conversations-window.unread.background = black
conversations-window.unread.foreground = red
# this is the message that shows available keybindings
keybindings-window.background = black
keybindings-window.foreground = #E2BE6F
keybindings-window.height = 1/2
# see configuration for tree in thread window above
keybindings-window.tree.branch.foreground = red
keybindings-window.tree.arrow.foreground = magenta
keybindings-window.tree.data.foreground = white
keybindings-window.tree.data-leaf.foreground = cyan
keybindings-window.tree.arrow.value = "🞂 "
keybindings-window.tree.leaf.value = "╰"
keybindings-window.tree.branch.value = "├"
keybindings-window.tree.spacer.value = "─"
keybindings-window.tree.vertical-line.value = "│"
# autocomplete window
suggestions-window.background = blue
suggestions-window.foreground = yellow
suggestions-window.height = 1/4
# the directive belows configure the window at the very bottom of the
# screen that user uses to give command to the program, also is used
# to shows some input errors or other informations
command-window.background = black
command-window.foreground = white
# text to separate keybindig added so far by the user
command-window.command-separator.value = " → "
# colors of the separator above
command-window.command-separator.foreground = yellow
command-window.command-separator.background = black
# color for error message shown in command window
command-window.error.message.background = black
command-window.error.message.foreground = red
command-window.error.message.attribute = bold
# color for info message shown in command window
command-window.info.message.foreground = yellow
command-window.info.message.background = black
command-window.info.message.attribute = bold
# this is the window that show the content of a message
message-window.background = black
message-window.foreground = #c9c0c0
# a marker on the right side of the window to show the position of the
# message is visualized in repect of the message lines length (similar
# to scrollbar in GUI)
message-window.line-position-mark.foreground = white
message-window.line-position-mark.background = black
# the text for the marker above
message-window.line-position-mark.value = "⧫"
# the date format for message
# values starting with '%' will be expanded, allowed values are:
# - %hour 0-23
# - %min
# - %second
# - %month numeric month
# - %year
# - %day day of the month
# - %weekday 0 to 7 (note: 0 is Sunday)
# - %short-weekday Sun to Mon
# - %long-weekday Sunday to Monday
# - %long-month Januray to December
# - %short-month Jan to Dec
# - %% a percent sign
message-window.date-format.value = "%year %short-month %day %hour:%min"
message-window.attachment-header.prefix.value = "~%──── "
message-window.attachment-header.postfix.value = " ────~%"
message-window.account.locked.mark.value = " 🔒"
message-window.account.unlocked.mark.value = " 🔓"
# the string for the header of attachments in a message, if not
# specified a default is chosen by the software.
#message-window.attachment-header.value = " attachment "
# this is the window that allow to browse the attachments of a message
open-attach-window.background = black
open-attach-window.foreground = #67998B
# the colors of selected attachments
open-attach-window.input.selected.background = black
open-attach-window.input.selected.foreground = #71AF8C

293
etc/init.lisp Normal file
View File

@ -0,0 +1,293 @@
;; this is the main configuration file for tinmop.
;; This file must be a valid common lisp program to allow the program
;; to even starts. This file is actual common lisp source code that is
;; loaded end executed by the main program; be careful, do not copy
;; and paste code from untrusted sources as this could results in a
;; *severe* security damage.
;; Anyway, even if you do not know lisp you should be able to change
;; keybindings with no difficult. Editing this file is the way to
;; accomplish this task.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This line on top of the file is mandatory if you want to write a
;; module (AKA plugin) for the program as the form below will provide
;; you with access to many program's machinery
(in-package :modules)
;; of course you can define new functions. Also note that the function called at
;; the end of the each command:
;;
;; (define-key "command keybinding" function)
;; ^^^^^^^^
;;
;; can not be an anonymous function.
(defun quit () ; define a custom function named 'quit' and no parameters
"Quit the program" ; this string after the function name and parameters is
; called 'docstring' and will be presented to the
; user as inline help
(ui:clean-close-program))
;; keybindings syntax:
;; a command is executed after a sequence of one or more keys. a key
;; can be composed by a single physical button pressed on the keyboard
;; or by a combination of a button pressed together.
;; Example of keys are:
;; "a" -> press the button on the keyboard with the symbol 'a' printed on top
;; "a b" -> press and release the button 'a' and then press the button 'b'
;; "f1 f2" -> press function key 1 and function key 2
;; sometimes a key is composed by two pressed buttons. For example to
;; input the character 'C' (i.e. capital 'c') usually you should use a
;; combination of SHIFT and C but there is more: a key can be composed
;; by two button pressed, the first called a "modifier" button.
;; The "modifier" button must be keep pressed
;; while the second button is hit for the key to be valid.
;; There are only two legal modifier buttons: the "Alt" button
;; (indicated with the letter "M") and the "Control" button (indicated
;; with "C").
;; So said some combined keys example are given:
;; "M-1" -> press "Alt" and, while pressed, press "1"
;; Note the dash between the symbols, the key below:
;; "M 1"
;; means: "Press the combination of button to print the capital button
;; 'M' and the button to print the character '1', so this is not
;; equivalent to "M-1".
;; With this information in mind we can decode more keys like the ones
;; given below:
;; "C-c x" -> Press control and keep pressed press 'c' then release
;; the two buttons and press 'x'.
;; "C-c c" -> Press control and keep pressed press 'c' then release
;; the two buttons and press 'c' again.
;; Caveat:
;; - The single letter after control modifier are case insensitive;
;; - the enter key must be specified by "C-J";
;; - "dc" is the key Delete;
;; To define a new key just use the 'define-key' form below:
;; (define key COMMAND FUNCTION)
;; Where COMMAND is a sequence of keys and FUNCTION is the name
;; (prefixed by: #') of the function to fire after command has been
;; completed
;; See the command below as examples.
;; key conflict
;; Sometime two commands key may conflict, for example:
;; (define "C-x a" #'foo)
;; (define "C-x a b" #'bar)
;; How the program could know which way choose when the button 'a' is
;; pressed? Should be executed the function 'foo' or should we go
;; beyond this function and wait for the button 'b' to be pressed?
;; The convention chosen is that will be executed the shorter path
;; that lead to a function so, in the case above, the function 'foo'
;; will be executed.
;; Note that the two command below are *not* in conflict:
;; (define "C-x a b c d" #'foo)
;; (define "C-x a e" #'bar)
;; global keymap
(define-key "C-q" #'quit) ; here we are calling the custom
; function defined above
(define-key "?" #'print-quick-help)
;; focus
(define-key "f1" #'focus-to-tags-window)
(define-key "f2" #'focus-to-thread-window)
(define-key "f3" #'focus-to-message-window)
(define-key "f4" #'focus-to-conversations-window)
;; follow requests keymap
(define-key "up" #'follow-request-go-up *follow-requests-keymap*)
(define-key "down" #'follow-request-go-down *follow-requests-keymap*)
(define-key "d" #'follow-request-delete *follow-requests-keymap*)
(define-key "C-J" #'process-follow-requests *follow-requests-keymap*)
(define-key "q" #'cancel-follow-requests *follow-requests-keymap*)
;; send message keymap
(define-key "up" #'attach-go-up *send-message-keymap*)
(define-key "down" #'attach-go-down *send-message-keymap*)
(define-key "d" #'attach-delete *send-message-keymap*)
(define-key "s" #'change-subject *send-message-keymap*)
(define-key "q" #'cancel-send-message *send-message-keymap*)
(define-key "v" #'change-visibility *send-message-keymap*)
(define-key "e" #'edit-message-body *send-message-keymap*)
(define-key "C-J" #'send-message *send-message-keymap*)
;; thread window keymap
(define-key "up" #'thread-go-up *thread-keymap*)
(define-key "down" #'thread-go-down *thread-keymap*)
(define-key "C-J" #'thread-open-selected-message *thread-keymap*)
(define-key "dc" #'thread-mark-delete-selected-message *thread-keymap*)
(define-key "U" #'thread-mark-prevent-delete-selected-message *thread-keymap*)
(define-key "g" #'thread-goto-message *thread-keymap*)
(define-key "/ b" #'thread-search-next-message-body *thread-keymap*)
(define-key "\\\\ b" #'thread-search-previous-message-body *thread-keymap*)
(define-key "/ m" #'thread-search-next-message-meta *thread-keymap*)
(define-key "\\\\ m" #'thread-search-previous-message-meta *thread-keymap*)
(define-key "n" #'thread-search-next-unread-message *thread-keymap*)
(define-key "home" #'thread-goto-first-message *thread-keymap*)
(define-key "end" #'thread-goto-last-message *thread-keymap*)
(define-key "c" #'compose-message *thread-keymap*)
(define-key "r" #'reply-message *thread-keymap*)
(define-key "v" #'open-message-attach *thread-keymap*)
(define-key "C-f c" #'change-folder *thread-keymap*)
(define-key "C-t c" #'change-timeline *thread-keymap*)
(define-key "C-t u" #'update-current-timeline *thread-keymap*)
(define-key "C-t h r" #'refresh-tags *thread-keymap*)
(define-key "C-X m t" #'move-message-tree *thread-keymap*)
(define-key "C-X m f" #'favourite-selected-status *thread-keymap*)
(define-key "C-X m r f" #'unfavourite-selected-status *thread-keymap*)
(define-key "C-X m b" #'boost-selected-status *thread-keymap*)
(define-key "C-X m r b" #'unboost-selected-status *thread-keymap*)
(define-key "C-X m s" #'subscribe-to-hash *thread-keymap*)
(define-key "C-X m u" #'unsubscribe-to-hash *thread-keymap*)
(define-key "C-u i" #'ignore-user *thread-keymap*)
(define-key "C-u x" #'unignore-user *thread-keymap*)
(define-key "C-u f" #'follow-user *thread-keymap*)
(define-key "C-u r f" #'start-follow-request-processing *thread-keymap*)
(define-key "C-u r r" #'report-status *thread-keymap*)
(define-key "C-u u" #'unfollow-user *thread-keymap*)
(define-key "C-u c k i" #'crypto-import-key *thread-keymap*)
(define-key "C-u c k s" #'crypto-export-key *thread-keymap*)
(define-key "C-u c k g" #'crypto-generate-key *thread-keymap*)
(define-key "C-c u" #'update-conversations *thread-keymap*)
(define-key "C-c o" #'open-conversation *thread-keymap*)
(define-key "C-c c" #'change-conversation-name *thread-keymap*)
;; message window keymap
(define-key "up" #'message-scroll-up *message-keymap*)
(define-key "down" #'message-scroll-down *message-keymap*)
(define-key "home" #'message-scroll-begin *message-keymap*)
(define-key "end" #'message-scroll-end *message-keymap*)
(define-key "/" #'message-search-regex *message-keymap*)
(define-key "npage" #'message-scroll-next-page *message-keymap*)
(define-key "ppage" #'message-scroll-previous-page *message-keymap*)
;; tags keymap
(define-key "up" #'tag-go-up *tags-keymap*)
(define-key "down" #'tag-go-down *tags-keymap*)
(define-key "C-J" #'open-tag-folder *tags-keymap*)
(define-key "C-X m u" #'unsubscribe-to-hash *tags-keymap*)
(define-key "C-t h r" #'refresh-tags *tags-keymap*)
;; conversations keymap
(define-key "C-J" #'goto-conversation *conversations-keymap*)
(define-key "up" #'conversation-go-up *conversations-keymap*)
(define-key "down" #'conversation-go-down *conversations-keymap*)
(define-key "dc" #'delete-conversation *conversations-keymap*)
(define-key "I" #'ignore-conversation *conversations-keymap*)
;; attachments keymap
(define-key "C-J" #'open-message-attach-perform-opening *open-attach-keymap*)
(define-key "up" #'open-message-attach-go-up *open-attach-keymap*)
(define-key "down" #'open-message-attach-go-down *open-attach-keymap*)
(define-key "q" #'close-open-message-window *open-attach-keymap*)

74
etc/shared.conf Normal file
View File

@ -0,0 +1,74 @@
# a line starting with a '#' is a comment
# The server instance name
# add this entry to your file (the one in your home)
# server = test.server.org
# your username
# add this entry to your file (the one in your home)
# username = username
# theme
use "default-theme.conf"
# maximum number of attachments allowed for a single toot
# default is 4
#max-numbers-allowed-attachments = 4
# maximum number of characters allowed for a single toot
# default is 500
#max-message-lenght = 500
# maximum number of characters allowed for reporting an user to
# instance's admin
#default is 100
#max-report-comment-length = 100
# Character to use when replying to a message
reply-quoted-character = "> "
# delete the command history entries that are older than this number
# of days
purge-history-days-offset = -7
# delete the cache entries that are older than this number of days
purge-cache-days-offset = -7
# chosen editor (as shell command line) for compose a message
editor = "nano --locking"
# color parts of a displayed message according to a regular expression
# syntax is regular expression color attribute
# valid color are specified using RGB triplets as #RRGGBB or color names
# valid color names are:
# - red
# - green
# - yellow
# - blue
# - magenta
# - cyan
# - white
#
# valid attributes are:
# - bold
# - italic
# - underline
# - blink
# attribute is optional
# Some examples follows
color-regexp = "http(s)?://[^ ]+" #ff0000
color-regexp = "(?i)(\\(c\\))|(\\(r\\))" #ff0000 bold
color-regexp = "[0-9]{4}-[0-9]?[0-9]-[0-9]?[0-9]" #0000ff bold
color-regexp = "-?[0-9]+%" #ff00ff bold
color-regexp = "\*[^*]+\*" #ffff00 bold
color-regexp = "_[^_]+_" #ffff00 underline
color-regexp = "/[^/]+/" #ffff00 italic

529
install-sh Executable file
View File

@ -0,0 +1,529 @@
#!/bin/sh
# install - install a program, script, or datafile
scriptversion=2018-03-11.20; # UTC
# This originates from X11R5 (mit/util/scripts/install.sh), which was
# later released in X11R6 (xc/config/util/install.sh) with the
# following copyright and license.
#
# Copyright (C) 1994 X Consortium
#
# 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
# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN
# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC-
# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
#
# Except as contained in this notice, the name of the X Consortium shall not
# be used in advertising or otherwise to promote the sale, use or other deal-
# ings in this Software without prior written authorization from the X Consor-
# tium.
#
#
# FSF changes to this file are in the public domain.
#
# Calling this script install-sh is preferred over install.sh, to prevent
# 'make' implicit rules from creating a file called install from it
# when there is no Makefile.
#
# This script is compatible with the BSD install script, but was written
# from scratch.
tab=' '
nl='
'
IFS=" $tab$nl"
# Set DOITPROG to "echo" to test this script.
doit=${DOITPROG-}
doit_exec=${doit:-exec}
# Put in absolute file names if you don't have them in your path;
# or use environment vars.
chgrpprog=${CHGRPPROG-chgrp}
chmodprog=${CHMODPROG-chmod}
chownprog=${CHOWNPROG-chown}
cmpprog=${CMPPROG-cmp}
cpprog=${CPPROG-cp}
mkdirprog=${MKDIRPROG-mkdir}
mvprog=${MVPROG-mv}
rmprog=${RMPROG-rm}
stripprog=${STRIPPROG-strip}
posix_mkdir=
# Desired mode of installed file.
mode=0755
chgrpcmd=
chmodcmd=$chmodprog
chowncmd=
mvcmd=$mvprog
rmcmd="$rmprog -f"
stripcmd=
src=
dst=
dir_arg=
dst_arg=
copy_on_change=false
is_target_a_directory=possibly
usage="\
Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE
or: $0 [OPTION]... SRCFILES... DIRECTORY
or: $0 [OPTION]... -t DIRECTORY SRCFILES...
or: $0 [OPTION]... -d DIRECTORIES...
In the 1st form, copy SRCFILE to DSTFILE.
In the 2nd and 3rd, copy all SRCFILES to DIRECTORY.
In the 4th, create DIRECTORIES.
Options:
--help display this help and exit.
--version display version info and exit.
-c (ignored)
-C install only if different (preserve the last data modification time)
-d create directories instead of installing files.
-g GROUP $chgrpprog installed files to GROUP.
-m MODE $chmodprog installed files to MODE.
-o USER $chownprog installed files to USER.
-s $stripprog installed files.
-t DIRECTORY install into DIRECTORY.
-T report an error if DSTFILE is a directory.
Environment variables override the default commands:
CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG
RMPROG STRIPPROG
"
while test $# -ne 0; do
case $1 in
-c) ;;
-C) copy_on_change=true;;
-d) dir_arg=true;;
-g) chgrpcmd="$chgrpprog $2"
shift;;
--help) echo "$usage"; exit $?;;
-m) mode=$2
case $mode in
*' '* | *"$tab"* | *"$nl"* | *'*'* | *'?'* | *'['*)
echo "$0: invalid mode: $mode" >&2
exit 1;;
esac
shift;;
-o) chowncmd="$chownprog $2"
shift;;
-s) stripcmd=$stripprog;;
-t)
is_target_a_directory=always
dst_arg=$2
# Protect names problematic for 'test' and other utilities.
case $dst_arg in
-* | [=\(\)!]) dst_arg=./$dst_arg;;
esac
shift;;
-T) is_target_a_directory=never;;
--version) echo "$0 $scriptversion"; exit $?;;
--) shift
break;;
-*) echo "$0: invalid option: $1" >&2
exit 1;;
*) break;;
esac
shift
done
# We allow the use of options -d and -T together, by making -d
# take the precedence; this is for compatibility with GNU install.
if test -n "$dir_arg"; then
if test -n "$dst_arg"; then
echo "$0: target directory not allowed when installing a directory." >&2
exit 1
fi
fi
if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then
# When -d is used, all remaining arguments are directories to create.
# When -t is used, the destination is already specified.
# Otherwise, the last argument is the destination. Remove it from $@.
for arg
do
if test -n "$dst_arg"; then
# $@ is not empty: it contains at least $arg.
set fnord "$@" "$dst_arg"
shift # fnord
fi
shift # arg
dst_arg=$arg
# Protect names problematic for 'test' and other utilities.
case $dst_arg in
-* | [=\(\)!]) dst_arg=./$dst_arg;;
esac
done
fi
if test $# -eq 0; then
if test -z "$dir_arg"; then
echo "$0: no input file specified." >&2
exit 1
fi
# It's OK to call 'install-sh -d' without argument.
# This can happen when creating conditional directories.
exit 0
fi
if test -z "$dir_arg"; then
if test $# -gt 1 || test "$is_target_a_directory" = always; then
if test ! -d "$dst_arg"; then
echo "$0: $dst_arg: Is not a directory." >&2
exit 1
fi
fi
fi
if test -z "$dir_arg"; then
do_exit='(exit $ret); exit $ret'
trap "ret=129; $do_exit" 1
trap "ret=130; $do_exit" 2
trap "ret=141; $do_exit" 13
trap "ret=143; $do_exit" 15
# Set umask so as not to create temps with too-generous modes.
# However, 'strip' requires both read and write access to temps.
case $mode in
# Optimize common cases.
*644) cp_umask=133;;
*755) cp_umask=22;;
*[0-7])
if test -z "$stripcmd"; then
u_plus_rw=
else
u_plus_rw='% 200'
fi
cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;;
*)
if test -z "$stripcmd"; then
u_plus_rw=
else
u_plus_rw=,u+rw
fi
cp_umask=$mode$u_plus_rw;;
esac
fi
for src
do
# Protect names problematic for 'test' and other utilities.
case $src in
-* | [=\(\)!]) src=./$src;;
esac
if test -n "$dir_arg"; then
dst=$src
dstdir=$dst
test -d "$dstdir"
dstdir_status=$?
else
# Waiting for this to be detected by the "$cpprog $src $dsttmp" command
# might cause directories to be created, which would be especially bad
# if $src (and thus $dsttmp) contains '*'.
if test ! -f "$src" && test ! -d "$src"; then
echo "$0: $src does not exist." >&2
exit 1
fi
if test -z "$dst_arg"; then
echo "$0: no destination specified." >&2
exit 1
fi
dst=$dst_arg
# If destination is a directory, append the input filename.
if test -d "$dst"; then
if test "$is_target_a_directory" = never; then
echo "$0: $dst_arg: Is a directory" >&2
exit 1
fi
dstdir=$dst
dstbase=`basename "$src"`
case $dst in
*/) dst=$dst$dstbase;;
*) dst=$dst/$dstbase;;
esac
dstdir_status=0
else
dstdir=`dirname "$dst"`
test -d "$dstdir"
dstdir_status=$?
fi
fi
case $dstdir in
*/) dstdirslash=$dstdir;;
*) dstdirslash=$dstdir/;;
esac
obsolete_mkdir_used=false
if test $dstdir_status != 0; then
case $posix_mkdir in
'')
# Create intermediate dirs using mode 755 as modified by the umask.
# This is like FreeBSD 'install' as of 1997-10-28.
umask=`umask`
case $stripcmd.$umask in
# Optimize common cases.
*[2367][2367]) mkdir_umask=$umask;;
.*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;;
*[0-7])
mkdir_umask=`expr $umask + 22 \
- $umask % 100 % 40 + $umask % 20 \
- $umask % 10 % 4 + $umask % 2
`;;
*) mkdir_umask=$umask,go-w;;
esac
# With -d, create the new directory with the user-specified mode.
# Otherwise, rely on $mkdir_umask.
if test -n "$dir_arg"; then
mkdir_mode=-m$mode
else
mkdir_mode=
fi
posix_mkdir=false
case $umask in
*[123567][0-7][0-7])
# POSIX mkdir -p sets u+wx bits regardless of umask, which
# is incompatible with FreeBSD 'install' when (umask & 300) != 0.
;;
*)
# Note that $RANDOM variable is not portable (e.g. dash); Use it
# here however when possible just to lower collision chance.
tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$
trap 'ret=$?; rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" 2>/dev/null; exit $ret' 0
# Because "mkdir -p" follows existing symlinks and we likely work
# directly in world-writeable /tmp, make sure that the '$tmpdir'
# directory is successfully created first before we actually test
# 'mkdir -p' feature.
if (umask $mkdir_umask &&
$mkdirprog $mkdir_mode "$tmpdir" &&
exec $mkdirprog $mkdir_mode -p -- "$tmpdir/a/b") >/dev/null 2>&1
then
if test -z "$dir_arg" || {
# Check for POSIX incompatibilities with -m.
# HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or
# other-writable bit of parent directory when it shouldn't.
# FreeBSD 6.1 mkdir -m -p sets mode of existing directory.
test_tmpdir="$tmpdir/a"
ls_ld_tmpdir=`ls -ld "$test_tmpdir"`
case $ls_ld_tmpdir in
d????-?r-*) different_mode=700;;
d????-?--*) different_mode=755;;
*) false;;
esac &&
$mkdirprog -m$different_mode -p -- "$test_tmpdir" && {
ls_ld_tmpdir_1=`ls -ld "$test_tmpdir"`
test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1"
}
}
then posix_mkdir=:
fi
rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir"
else
# Remove any dirs left behind by ancient mkdir implementations.
rmdir ./$mkdir_mode ./-p ./-- "$tmpdir" 2>/dev/null
fi
trap '' 0;;
esac;;
esac
if
$posix_mkdir && (
umask $mkdir_umask &&
$doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir"
)
then :
else
# The umask is ridiculous, or mkdir does not conform to POSIX,
# or it failed possibly due to a race condition. Create the
# directory the slow way, step by step, checking for races as we go.
case $dstdir in
/*) prefix='/';;
[-=\(\)!]*) prefix='./';;
*) prefix='';;
esac
oIFS=$IFS
IFS=/
set -f
set fnord $dstdir
shift
set +f
IFS=$oIFS
prefixes=
for d
do
test X"$d" = X && continue
prefix=$prefix$d
if test -d "$prefix"; then
prefixes=
else
if $posix_mkdir; then
(umask=$mkdir_umask &&
$doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break
# Don't fail if two instances are running concurrently.
test -d "$prefix" || exit 1
else
case $prefix in
*\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;;
*) qprefix=$prefix;;
esac
prefixes="$prefixes '$qprefix'"
fi
fi
prefix=$prefix/
done
if test -n "$prefixes"; then
# Don't fail if two instances are running concurrently.
(umask $mkdir_umask &&
eval "\$doit_exec \$mkdirprog $prefixes") ||
test -d "$dstdir" || exit 1
obsolete_mkdir_used=true
fi
fi
fi
if test -n "$dir_arg"; then
{ test -z "$chowncmd" || $doit $chowncmd "$dst"; } &&
{ test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } &&
{ test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false ||
test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1
else
# Make a couple of temp file names in the proper directory.
dsttmp=${dstdirslash}_inst.$$_
rmtmp=${dstdirslash}_rm.$$_
# Trap to clean up those temp files at exit.
trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0
# Copy the file name to the temp name.
(umask $cp_umask &&
{ test -z "$stripcmd" || {
# Create $dsttmp read-write so that cp doesn't create it read-only,
# which would cause strip to fail.
if test -z "$doit"; then
: >"$dsttmp" # No need to fork-exec 'touch'.
else
$doit touch "$dsttmp"
fi
}
} &&
$doit_exec $cpprog "$src" "$dsttmp") &&
# and set any options; do chmod last to preserve setuid bits.
#
# If any of these fail, we abort the whole thing. If we want to
# ignore errors from any of these, just make sure not to ignore
# errors from the above "$doit $cpprog $src $dsttmp" command.
#
{ test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } &&
{ test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } &&
{ test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } &&
{ test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } &&
# If -C, don't bother to copy if it wouldn't change the file.
if $copy_on_change &&
old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` &&
new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` &&
set -f &&
set X $old && old=:$2:$4:$5:$6 &&
set X $new && new=:$2:$4:$5:$6 &&
set +f &&
test "$old" = "$new" &&
$cmpprog "$dst" "$dsttmp" >/dev/null 2>&1
then
rm -f "$dsttmp"
else
# Rename the file to the real destination.
$doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null ||
# The rename failed, perhaps because mv can't rename something else
# to itself, or perhaps because mv is so ancient that it does not
# support -f.
{
# Now remove or move aside any old file at destination location.
# We try this two ways since rm can't unlink itself on some
# systems and the destination file might be busy for other
# reasons. In this case, the final cleanup might fail but the new
# file should still install successfully.
{
test ! -f "$dst" ||
$doit $rmcmd -f "$dst" 2>/dev/null ||
{ $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null &&
{ $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; }
} ||
{ echo "$0: cannot unlink or rename $dst" >&2
(exit 1); exit 1
}
} &&
# Now rename the file to the real destination.
$doit $mvcmd "$dsttmp" "$dst"
}
fi || exit 1
trap '' 0
fi
done
# Local variables:
# eval: (add-hook 'before-save-hook 'time-stamp)
# time-stamp-start: "scriptversion="
# time-stamp-format: "%:y-%02m-%02d.%02H"
# time-stamp-time-zone: "UTC0"
# time-stamp-end: "; # UTC"
# End:

11
m4/ChangeLog Normal file
View File

@ -0,0 +1,11 @@
2019-12-26 gettextize <bug-gnu-gettext@gnu.org>
* gettext.m4: New file, from gettext-0.19.8.1.
* iconv.m4: New file, from gettext-0.19.8.1.
* lib-ld.m4: New file, from gettext-0.19.8.1.
* lib-link.m4: New file, from gettext-0.19.8.1.
* lib-prefix.m4: New file, from gettext-0.19.8.1.
* nls.m4: New file, from gettext-0.19.8.1.
* po.m4: New file, from gettext-0.19.8.1.
* progtest.m4: New file, from gettext-0.19.8.1.

420
m4/gettext.m4 Normal file
View File

@ -0,0 +1,420 @@
# gettext.m4 serial 68 (gettext-0.19.8)
dnl Copyright (C) 1995-2014, 2016 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
dnl
dnl This file can be used in projects which are not available under
dnl the GNU General Public License or the GNU Library General Public
dnl License but which still want to provide support for the GNU gettext
dnl functionality.
dnl Please note that the actual code of the GNU gettext library is covered
dnl by the GNU Library General Public License, and the rest of the GNU
dnl gettext package is covered by the GNU General Public License.
dnl They are *not* in the public domain.
dnl Authors:
dnl Ulrich Drepper <drepper@cygnus.com>, 1995-2000.
dnl Bruno Haible <haible@clisp.cons.org>, 2000-2006, 2008-2010.
dnl Macro to add for using GNU gettext.
dnl Usage: AM_GNU_GETTEXT([INTLSYMBOL], [NEEDSYMBOL], [INTLDIR]).
dnl INTLSYMBOL can be one of 'external', 'no-libtool', 'use-libtool'. The
dnl default (if it is not specified or empty) is 'no-libtool'.
dnl INTLSYMBOL should be 'external' for packages with no intl directory,
dnl and 'no-libtool' or 'use-libtool' for packages with an intl directory.
dnl If INTLSYMBOL is 'use-libtool', then a libtool library
dnl $(top_builddir)/intl/libintl.la will be created (shared and/or static,
dnl depending on --{enable,disable}-{shared,static} and on the presence of
dnl AM-DISABLE-SHARED). If INTLSYMBOL is 'no-libtool', a static library
dnl $(top_builddir)/intl/libintl.a will be created.
dnl If NEEDSYMBOL is specified and is 'need-ngettext', then GNU gettext
dnl implementations (in libc or libintl) without the ngettext() function
dnl will be ignored. If NEEDSYMBOL is specified and is
dnl 'need-formatstring-macros', then GNU gettext implementations that don't
dnl support the ISO C 99 <inttypes.h> formatstring macros will be ignored.
dnl INTLDIR is used to find the intl libraries. If empty,
dnl the value '$(top_builddir)/intl/' is used.
dnl
dnl The result of the configuration is one of three cases:
dnl 1) GNU gettext, as included in the intl subdirectory, will be compiled
dnl and used.
dnl Catalog format: GNU --> install in $(datadir)
dnl Catalog extension: .mo after installation, .gmo in source tree
dnl 2) GNU gettext has been found in the system's C library.
dnl Catalog format: GNU --> install in $(datadir)
dnl Catalog extension: .mo after installation, .gmo in source tree
dnl 3) No internationalization, always use English msgid.
dnl Catalog format: none
dnl Catalog extension: none
dnl If INTLSYMBOL is 'external', only cases 2 and 3 can occur.
dnl The use of .gmo is historical (it was needed to avoid overwriting the
dnl GNU format catalogs when building on a platform with an X/Open gettext),
dnl but we keep it in order not to force irrelevant filename changes on the
dnl maintainers.
dnl
AC_DEFUN([AM_GNU_GETTEXT],
[
dnl Argument checking.
ifelse([$1], [], , [ifelse([$1], [external], , [ifelse([$1], [no-libtool], , [ifelse([$1], [use-libtool], ,
[errprint([ERROR: invalid first argument to AM_GNU_GETTEXT
])])])])])
ifelse(ifelse([$1], [], [old])[]ifelse([$1], [no-libtool], [old]), [old],
[AC_DIAGNOSE([obsolete], [Use of AM_GNU_GETTEXT without [external] argument is deprecated.])])
ifelse([$2], [], , [ifelse([$2], [need-ngettext], , [ifelse([$2], [need-formatstring-macros], ,
[errprint([ERROR: invalid second argument to AM_GNU_GETTEXT
])])])])
define([gt_included_intl],
ifelse([$1], [external],
ifdef([AM_GNU_GETTEXT_][INTL_SUBDIR], [yes], [no]),
[yes]))
define([gt_libtool_suffix_prefix], ifelse([$1], [use-libtool], [l], []))
gt_NEEDS_INIT
AM_GNU_GETTEXT_NEED([$2])
AC_REQUIRE([AM_PO_SUBDIRS])dnl
ifelse(gt_included_intl, yes, [
AC_REQUIRE([AM_INTL_SUBDIR])dnl
])
dnl Prerequisites of AC_LIB_LINKFLAGS_BODY.
AC_REQUIRE([AC_LIB_PREPARE_PREFIX])
AC_REQUIRE([AC_LIB_RPATH])
dnl Sometimes libintl requires libiconv, so first search for libiconv.
dnl Ideally we would do this search only after the
dnl if test "$USE_NLS" = "yes"; then
dnl if { eval "gt_val=\$$gt_func_gnugettext_libc"; test "$gt_val" != "yes"; }; then
dnl tests. But if configure.in invokes AM_ICONV after AM_GNU_GETTEXT
dnl the configure script would need to contain the same shell code
dnl again, outside any 'if'. There are two solutions:
dnl - Invoke AM_ICONV_LINKFLAGS_BODY here, outside any 'if'.
dnl - Control the expansions in more detail using AC_PROVIDE_IFELSE.
dnl Since AC_PROVIDE_IFELSE is only in autoconf >= 2.52 and not
dnl documented, we avoid it.
ifelse(gt_included_intl, yes, , [
AC_REQUIRE([AM_ICONV_LINKFLAGS_BODY])
])
dnl Sometimes, on Mac OS X, libintl requires linking with CoreFoundation.
gt_INTL_MACOSX
dnl Set USE_NLS.
AC_REQUIRE([AM_NLS])
ifelse(gt_included_intl, yes, [
BUILD_INCLUDED_LIBINTL=no
USE_INCLUDED_LIBINTL=no
])
LIBINTL=
LTLIBINTL=
POSUB=
dnl Add a version number to the cache macros.
case " $gt_needs " in
*" need-formatstring-macros "*) gt_api_version=3 ;;
*" need-ngettext "*) gt_api_version=2 ;;
*) gt_api_version=1 ;;
esac
gt_func_gnugettext_libc="gt_cv_func_gnugettext${gt_api_version}_libc"
gt_func_gnugettext_libintl="gt_cv_func_gnugettext${gt_api_version}_libintl"
dnl If we use NLS figure out what method
if test "$USE_NLS" = "yes"; then
gt_use_preinstalled_gnugettext=no
ifelse(gt_included_intl, yes, [
AC_MSG_CHECKING([whether included gettext is requested])
AC_ARG_WITH([included-gettext],
[ --with-included-gettext use the GNU gettext library included here],
nls_cv_force_use_gnu_gettext=$withval,
nls_cv_force_use_gnu_gettext=no)
AC_MSG_RESULT([$nls_cv_force_use_gnu_gettext])
nls_cv_use_gnu_gettext="$nls_cv_force_use_gnu_gettext"
if test "$nls_cv_force_use_gnu_gettext" != "yes"; then
])
dnl User does not insist on using GNU NLS library. Figure out what
dnl to use. If GNU gettext is available we use this. Else we have
dnl to fall back to GNU NLS library.
if test $gt_api_version -ge 3; then
gt_revision_test_code='
#ifndef __GNU_GETTEXT_SUPPORTED_REVISION
#define __GNU_GETTEXT_SUPPORTED_REVISION(major) ((major) == 0 ? 0 : -1)
#endif
changequote(,)dnl
typedef int array [2 * (__GNU_GETTEXT_SUPPORTED_REVISION(0) >= 1) - 1];
changequote([,])dnl
'
else
gt_revision_test_code=
fi
if test $gt_api_version -ge 2; then
gt_expression_test_code=' + * ngettext ("", "", 0)'
else
gt_expression_test_code=
fi
AC_CACHE_CHECK([for GNU gettext in libc], [$gt_func_gnugettext_libc],
[AC_LINK_IFELSE(
[AC_LANG_PROGRAM(
[[
#include <libintl.h>
#ifndef __GNU_GETTEXT_SUPPORTED_REVISION
extern int _nl_msg_cat_cntr;
extern int *_nl_domain_bindings;
#define __GNU_GETTEXT_SYMBOL_EXPRESSION (_nl_msg_cat_cntr + *_nl_domain_bindings)
#else
#define __GNU_GETTEXT_SYMBOL_EXPRESSION 0
#endif
$gt_revision_test_code
]],
[[
bindtextdomain ("", "");
return * gettext ("")$gt_expression_test_code + __GNU_GETTEXT_SYMBOL_EXPRESSION
]])],
[eval "$gt_func_gnugettext_libc=yes"],
[eval "$gt_func_gnugettext_libc=no"])])
if { eval "gt_val=\$$gt_func_gnugettext_libc"; test "$gt_val" != "yes"; }; then
dnl Sometimes libintl requires libiconv, so first search for libiconv.
ifelse(gt_included_intl, yes, , [
AM_ICONV_LINK
])
dnl Search for libintl and define LIBINTL, LTLIBINTL and INCINTL
dnl accordingly. Don't use AC_LIB_LINKFLAGS_BODY([intl],[iconv])
dnl because that would add "-liconv" to LIBINTL and LTLIBINTL
dnl even if libiconv doesn't exist.
AC_LIB_LINKFLAGS_BODY([intl])
AC_CACHE_CHECK([for GNU gettext in libintl],
[$gt_func_gnugettext_libintl],
[gt_save_CPPFLAGS="$CPPFLAGS"
CPPFLAGS="$CPPFLAGS $INCINTL"
gt_save_LIBS="$LIBS"
LIBS="$LIBS $LIBINTL"
dnl Now see whether libintl exists and does not depend on libiconv.
AC_LINK_IFELSE(
[AC_LANG_PROGRAM(
[[
#include <libintl.h>
#ifndef __GNU_GETTEXT_SUPPORTED_REVISION
extern int _nl_msg_cat_cntr;
extern
#ifdef __cplusplus
"C"
#endif
const char *_nl_expand_alias (const char *);
#define __GNU_GETTEXT_SYMBOL_EXPRESSION (_nl_msg_cat_cntr + *_nl_expand_alias (""))
#else
#define __GNU_GETTEXT_SYMBOL_EXPRESSION 0
#endif
$gt_revision_test_code
]],
[[
bindtextdomain ("", "");
return * gettext ("")$gt_expression_test_code + __GNU_GETTEXT_SYMBOL_EXPRESSION
]])],
[eval "$gt_func_gnugettext_libintl=yes"],
[eval "$gt_func_gnugettext_libintl=no"])
dnl Now see whether libintl exists and depends on libiconv.
if { eval "gt_val=\$$gt_func_gnugettext_libintl"; test "$gt_val" != yes; } && test -n "$LIBICONV"; then
LIBS="$LIBS $LIBICONV"
AC_LINK_IFELSE(
[AC_LANG_PROGRAM(
[[
#include <libintl.h>
#ifndef __GNU_GETTEXT_SUPPORTED_REVISION
extern int _nl_msg_cat_cntr;
extern
#ifdef __cplusplus
"C"
#endif
const char *_nl_expand_alias (const char *);
#define __GNU_GETTEXT_SYMBOL_EXPRESSION (_nl_msg_cat_cntr + *_nl_expand_alias (""))
#else
#define __GNU_GETTEXT_SYMBOL_EXPRESSION 0
#endif
$gt_revision_test_code
]],
[[
bindtextdomain ("", "");
return * gettext ("")$gt_expression_test_code + __GNU_GETTEXT_SYMBOL_EXPRESSION
]])],
[LIBINTL="$LIBINTL $LIBICONV"
LTLIBINTL="$LTLIBINTL $LTLIBICONV"
eval "$gt_func_gnugettext_libintl=yes"
])
fi
CPPFLAGS="$gt_save_CPPFLAGS"
LIBS="$gt_save_LIBS"])
fi
dnl If an already present or preinstalled GNU gettext() is found,
dnl use it. But if this macro is used in GNU gettext, and GNU
dnl gettext is already preinstalled in libintl, we update this
dnl libintl. (Cf. the install rule in intl/Makefile.in.)
if { eval "gt_val=\$$gt_func_gnugettext_libc"; test "$gt_val" = "yes"; } \
|| { { eval "gt_val=\$$gt_func_gnugettext_libintl"; test "$gt_val" = "yes"; } \
&& test "$PACKAGE" != gettext-runtime \
&& test "$PACKAGE" != gettext-tools; }; then
gt_use_preinstalled_gnugettext=yes
else
dnl Reset the values set by searching for libintl.
LIBINTL=
LTLIBINTL=
INCINTL=
fi
ifelse(gt_included_intl, yes, [
if test "$gt_use_preinstalled_gnugettext" != "yes"; then
dnl GNU gettext is not found in the C library.
dnl Fall back on included GNU gettext library.
nls_cv_use_gnu_gettext=yes
fi
fi
if test "$nls_cv_use_gnu_gettext" = "yes"; then
dnl Mark actions used to generate GNU NLS library.
BUILD_INCLUDED_LIBINTL=yes
USE_INCLUDED_LIBINTL=yes
LIBINTL="ifelse([$3],[],\${top_builddir}/intl,[$3])/libintl.[]gt_libtool_suffix_prefix[]a $LIBICONV $LIBTHREAD"
LTLIBINTL="ifelse([$3],[],\${top_builddir}/intl,[$3])/libintl.[]gt_libtool_suffix_prefix[]a $LTLIBICONV $LTLIBTHREAD"
LIBS=`echo " $LIBS " | sed -e 's/ -lintl / /' -e 's/^ //' -e 's/ $//'`
fi
CATOBJEXT=
if test "$gt_use_preinstalled_gnugettext" = "yes" \
|| test "$nls_cv_use_gnu_gettext" = "yes"; then
dnl Mark actions to use GNU gettext tools.
CATOBJEXT=.gmo
fi
])
if test -n "$INTL_MACOSX_LIBS"; then
if test "$gt_use_preinstalled_gnugettext" = "yes" \
|| test "$nls_cv_use_gnu_gettext" = "yes"; then
dnl Some extra flags are needed during linking.
LIBINTL="$LIBINTL $INTL_MACOSX_LIBS"
LTLIBINTL="$LTLIBINTL $INTL_MACOSX_LIBS"
fi
fi
if test "$gt_use_preinstalled_gnugettext" = "yes" \
|| test "$nls_cv_use_gnu_gettext" = "yes"; then
AC_DEFINE([ENABLE_NLS], [1],
[Define to 1 if translation of program messages to the user's native language
is requested.])
else
USE_NLS=no
fi
fi
AC_MSG_CHECKING([whether to use NLS])
AC_MSG_RESULT([$USE_NLS])
if test "$USE_NLS" = "yes"; then
AC_MSG_CHECKING([where the gettext function comes from])
if test "$gt_use_preinstalled_gnugettext" = "yes"; then
if { eval "gt_val=\$$gt_func_gnugettext_libintl"; test "$gt_val" = "yes"; }; then
gt_source="external libintl"
else
gt_source="libc"
fi
else
gt_source="included intl directory"
fi
AC_MSG_RESULT([$gt_source])
fi
if test "$USE_NLS" = "yes"; then
if test "$gt_use_preinstalled_gnugettext" = "yes"; then
if { eval "gt_val=\$$gt_func_gnugettext_libintl"; test "$gt_val" = "yes"; }; then
AC_MSG_CHECKING([how to link with libintl])
AC_MSG_RESULT([$LIBINTL])
AC_LIB_APPENDTOVAR([CPPFLAGS], [$INCINTL])
fi
dnl For backward compatibility. Some packages may be using this.
AC_DEFINE([HAVE_GETTEXT], [1],
[Define if the GNU gettext() function is already present or preinstalled.])
AC_DEFINE([HAVE_DCGETTEXT], [1],
[Define if the GNU dcgettext() function is already present or preinstalled.])
fi
dnl We need to process the po/ directory.
POSUB=po
fi
ifelse(gt_included_intl, yes, [
dnl If this is used in GNU gettext we have to set BUILD_INCLUDED_LIBINTL
dnl to 'yes' because some of the testsuite requires it.
if test "$PACKAGE" = gettext-runtime || test "$PACKAGE" = gettext-tools; then
BUILD_INCLUDED_LIBINTL=yes
fi
dnl Make all variables we use known to autoconf.
AC_SUBST([BUILD_INCLUDED_LIBINTL])
AC_SUBST([USE_INCLUDED_LIBINTL])
AC_SUBST([CATOBJEXT])
dnl For backward compatibility. Some configure.ins may be using this.
nls_cv_header_intl=
nls_cv_header_libgt=
dnl For backward compatibility. Some Makefiles may be using this.
DATADIRNAME=share
AC_SUBST([DATADIRNAME])
dnl For backward compatibility. Some Makefiles may be using this.
INSTOBJEXT=.mo
AC_SUBST([INSTOBJEXT])
dnl For backward compatibility. Some Makefiles may be using this.
GENCAT=gencat
AC_SUBST([GENCAT])
dnl For backward compatibility. Some Makefiles may be using this.
INTLOBJS=
if test "$USE_INCLUDED_LIBINTL" = yes; then
INTLOBJS="\$(GETTOBJS)"
fi
AC_SUBST([INTLOBJS])
dnl Enable libtool support if the surrounding package wishes it.
INTL_LIBTOOL_SUFFIX_PREFIX=gt_libtool_suffix_prefix
AC_SUBST([INTL_LIBTOOL_SUFFIX_PREFIX])
])
dnl For backward compatibility. Some Makefiles may be using this.
INTLLIBS="$LIBINTL"
AC_SUBST([INTLLIBS])
dnl Make all documented variables known to autoconf.
AC_SUBST([LIBINTL])
AC_SUBST([LTLIBINTL])
AC_SUBST([POSUB])
])
dnl gt_NEEDS_INIT ensures that the gt_needs variable is initialized.
m4_define([gt_NEEDS_INIT],
[
m4_divert_text([DEFAULTS], [gt_needs=])
m4_define([gt_NEEDS_INIT], [])
])
dnl Usage: AM_GNU_GETTEXT_NEED([NEEDSYMBOL])
AC_DEFUN([AM_GNU_GETTEXT_NEED],
[
m4_divert_text([INIT_PREPARE], [gt_needs="$gt_needs $1"])
])
dnl Usage: AM_GNU_GETTEXT_VERSION([gettext-version])
AC_DEFUN([AM_GNU_GETTEXT_VERSION], [])
dnl Usage: AM_GNU_GETTEXT_REQUIRE_VERSION([gettext-version])
AC_DEFUN([AM_GNU_GETTEXT_REQUIRE_VERSION], [])

271
m4/iconv.m4 Normal file
View File

@ -0,0 +1,271 @@
# iconv.m4 serial 19 (gettext-0.18.2)
dnl Copyright (C) 2000-2002, 2007-2014, 2016 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
dnl From Bruno Haible.
AC_DEFUN([AM_ICONV_LINKFLAGS_BODY],
[
dnl Prerequisites of AC_LIB_LINKFLAGS_BODY.
AC_REQUIRE([AC_LIB_PREPARE_PREFIX])
AC_REQUIRE([AC_LIB_RPATH])
dnl Search for libiconv and define LIBICONV, LTLIBICONV and INCICONV
dnl accordingly.
AC_LIB_LINKFLAGS_BODY([iconv])
])
AC_DEFUN([AM_ICONV_LINK],
[
dnl Some systems have iconv in libc, some have it in libiconv (OSF/1 and
dnl those with the standalone portable GNU libiconv installed).
AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
dnl Search for libiconv and define LIBICONV, LTLIBICONV and INCICONV
dnl accordingly.
AC_REQUIRE([AM_ICONV_LINKFLAGS_BODY])
dnl Add $INCICONV to CPPFLAGS before performing the following checks,
dnl because if the user has installed libiconv and not disabled its use
dnl via --without-libiconv-prefix, he wants to use it. The first
dnl AC_LINK_IFELSE will then fail, the second AC_LINK_IFELSE will succeed.
am_save_CPPFLAGS="$CPPFLAGS"
AC_LIB_APPENDTOVAR([CPPFLAGS], [$INCICONV])
AC_CACHE_CHECK([for iconv], [am_cv_func_iconv], [
am_cv_func_iconv="no, consider installing GNU libiconv"
am_cv_lib_iconv=no
AC_LINK_IFELSE(
[AC_LANG_PROGRAM(
[[
#include <stdlib.h>
#include <iconv.h>
]],
[[iconv_t cd = iconv_open("","");
iconv(cd,NULL,NULL,NULL,NULL);
iconv_close(cd);]])],
[am_cv_func_iconv=yes])
if test "$am_cv_func_iconv" != yes; then
am_save_LIBS="$LIBS"
LIBS="$LIBS $LIBICONV"
AC_LINK_IFELSE(
[AC_LANG_PROGRAM(
[[
#include <stdlib.h>
#include <iconv.h>
]],
[[iconv_t cd = iconv_open("","");
iconv(cd,NULL,NULL,NULL,NULL);
iconv_close(cd);]])],
[am_cv_lib_iconv=yes]
[am_cv_func_iconv=yes])
LIBS="$am_save_LIBS"
fi
])
if test "$am_cv_func_iconv" = yes; then
AC_CACHE_CHECK([for working iconv], [am_cv_func_iconv_works], [
dnl This tests against bugs in AIX 5.1, AIX 6.1..7.1, HP-UX 11.11,
dnl Solaris 10.
am_save_LIBS="$LIBS"
if test $am_cv_lib_iconv = yes; then
LIBS="$LIBS $LIBICONV"
fi
am_cv_func_iconv_works=no
for ac_iconv_const in '' 'const'; do
AC_RUN_IFELSE(
[AC_LANG_PROGRAM(
[[
#include <iconv.h>
#include <string.h>
#ifndef ICONV_CONST
# define ICONV_CONST $ac_iconv_const
#endif
]],
[[int result = 0;
/* Test against AIX 5.1 bug: Failures are not distinguishable from successful
returns. */
{
iconv_t cd_utf8_to_88591 = iconv_open ("ISO8859-1", "UTF-8");
if (cd_utf8_to_88591 != (iconv_t)(-1))
{
static ICONV_CONST char input[] = "\342\202\254"; /* EURO SIGN */
char buf[10];
ICONV_CONST char *inptr = input;
size_t inbytesleft = strlen (input);
char *outptr = buf;
size_t outbytesleft = sizeof (buf);
size_t res = iconv (cd_utf8_to_88591,
&inptr, &inbytesleft,
&outptr, &outbytesleft);
if (res == 0)
result |= 1;
iconv_close (cd_utf8_to_88591);
}
}
/* Test against Solaris 10 bug: Failures are not distinguishable from
successful returns. */
{
iconv_t cd_ascii_to_88591 = iconv_open ("ISO8859-1", "646");
if (cd_ascii_to_88591 != (iconv_t)(-1))
{
static ICONV_CONST char input[] = "\263";
char buf[10];
ICONV_CONST char *inptr = input;
size_t inbytesleft = strlen (input);
char *outptr = buf;
size_t outbytesleft = sizeof (buf);
size_t res = iconv (cd_ascii_to_88591,
&inptr, &inbytesleft,
&outptr, &outbytesleft);
if (res == 0)
result |= 2;
iconv_close (cd_ascii_to_88591);
}
}
/* Test against AIX 6.1..7.1 bug: Buffer overrun. */
{
iconv_t cd_88591_to_utf8 = iconv_open ("UTF-8", "ISO-8859-1");
if (cd_88591_to_utf8 != (iconv_t)(-1))
{
static ICONV_CONST char input[] = "\304";
static char buf[2] = { (char)0xDE, (char)0xAD };
ICONV_CONST char *inptr = input;
size_t inbytesleft = 1;
char *outptr = buf;
size_t outbytesleft = 1;
size_t res = iconv (cd_88591_to_utf8,
&inptr, &inbytesleft,
&outptr, &outbytesleft);
if (res != (size_t)(-1) || outptr - buf > 1 || buf[1] != (char)0xAD)
result |= 4;
iconv_close (cd_88591_to_utf8);
}
}
#if 0 /* This bug could be worked around by the caller. */
/* Test against HP-UX 11.11 bug: Positive return value instead of 0. */
{
iconv_t cd_88591_to_utf8 = iconv_open ("utf8", "iso88591");
if (cd_88591_to_utf8 != (iconv_t)(-1))
{
static ICONV_CONST char input[] = "\304rger mit b\366sen B\374bchen ohne Augenma\337";
char buf[50];
ICONV_CONST char *inptr = input;
size_t inbytesleft = strlen (input);
char *outptr = buf;
size_t outbytesleft = sizeof (buf);
size_t res = iconv (cd_88591_to_utf8,
&inptr, &inbytesleft,
&outptr, &outbytesleft);
if ((int)res > 0)
result |= 8;
iconv_close (cd_88591_to_utf8);
}
}
#endif
/* Test against HP-UX 11.11 bug: No converter from EUC-JP to UTF-8 is
provided. */
if (/* Try standardized names. */
iconv_open ("UTF-8", "EUC-JP") == (iconv_t)(-1)
/* Try IRIX, OSF/1 names. */
&& iconv_open ("UTF-8", "eucJP") == (iconv_t)(-1)
/* Try AIX names. */
&& iconv_open ("UTF-8", "IBM-eucJP") == (iconv_t)(-1)
/* Try HP-UX names. */
&& iconv_open ("utf8", "eucJP") == (iconv_t)(-1))
result |= 16;
return result;
]])],
[am_cv_func_iconv_works=yes], ,
[case "$host_os" in
aix* | hpux*) am_cv_func_iconv_works="guessing no" ;;
*) am_cv_func_iconv_works="guessing yes" ;;
esac])
test "$am_cv_func_iconv_works" = no || break
done
LIBS="$am_save_LIBS"
])
case "$am_cv_func_iconv_works" in
*no) am_func_iconv=no am_cv_lib_iconv=no ;;
*) am_func_iconv=yes ;;
esac
else
am_func_iconv=no am_cv_lib_iconv=no
fi
if test "$am_func_iconv" = yes; then
AC_DEFINE([HAVE_ICONV], [1],
[Define if you have the iconv() function and it works.])
fi
if test "$am_cv_lib_iconv" = yes; then
AC_MSG_CHECKING([how to link with libiconv])
AC_MSG_RESULT([$LIBICONV])
else
dnl If $LIBICONV didn't lead to a usable library, we don't need $INCICONV
dnl either.
CPPFLAGS="$am_save_CPPFLAGS"
LIBICONV=
LTLIBICONV=
fi
AC_SUBST([LIBICONV])
AC_SUBST([LTLIBICONV])
])
dnl Define AM_ICONV using AC_DEFUN_ONCE for Autoconf >= 2.64, in order to
dnl avoid warnings like
dnl "warning: AC_REQUIRE: `AM_ICONV' was expanded before it was required".
dnl This is tricky because of the way 'aclocal' is implemented:
dnl - It requires defining an auxiliary macro whose name ends in AC_DEFUN.
dnl Otherwise aclocal's initial scan pass would miss the macro definition.
dnl - It requires a line break inside the AC_DEFUN_ONCE and AC_DEFUN expansions.
dnl Otherwise aclocal would emit many "Use of uninitialized value $1"
dnl warnings.
m4_define([gl_iconv_AC_DEFUN],
m4_version_prereq([2.64],
[[AC_DEFUN_ONCE(
[$1], [$2])]],
[m4_ifdef([gl_00GNULIB],
[[AC_DEFUN_ONCE(
[$1], [$2])]],
[[AC_DEFUN(
[$1], [$2])]])]))
gl_iconv_AC_DEFUN([AM_ICONV],
[
AM_ICONV_LINK
if test "$am_cv_func_iconv" = yes; then
AC_MSG_CHECKING([for iconv declaration])
AC_CACHE_VAL([am_cv_proto_iconv], [
AC_COMPILE_IFELSE(
[AC_LANG_PROGRAM(
[[
#include <stdlib.h>
#include <iconv.h>
extern
#ifdef __cplusplus
"C"
#endif
#if defined(__STDC__) || defined(_MSC_VER) || defined(__cplusplus)
size_t iconv (iconv_t cd, char * *inbuf, size_t *inbytesleft, char * *outbuf, size_t *outbytesleft);
#else
size_t iconv();
#endif
]],
[[]])],
[am_cv_proto_iconv_arg1=""],
[am_cv_proto_iconv_arg1="const"])
am_cv_proto_iconv="extern size_t iconv (iconv_t cd, $am_cv_proto_iconv_arg1 char * *inbuf, size_t *inbytesleft, char * *outbuf, size_t *outbytesleft);"])
am_cv_proto_iconv=`echo "[$]am_cv_proto_iconv" | tr -s ' ' | sed -e 's/( /(/'`
AC_MSG_RESULT([
$am_cv_proto_iconv])
AC_DEFINE_UNQUOTED([ICONV_CONST], [$am_cv_proto_iconv_arg1],
[Define as const if the declaration of iconv() needs const.])
dnl Also substitute ICONV_CONST in the gnulib generated <iconv.h>.
m4_ifdef([gl_ICONV_H_DEFAULTS],
[AC_REQUIRE([gl_ICONV_H_DEFAULTS])
if test -n "$am_cv_proto_iconv_arg1"; then
ICONV_CONST="const"
fi
])
fi
])

119
m4/lib-ld.m4 Normal file
View File

@ -0,0 +1,119 @@
# lib-ld.m4 serial 6
dnl Copyright (C) 1996-2003, 2009-2016 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
dnl Subroutines of libtool.m4,
dnl with replacements s/_*LT_PATH/AC_LIB_PROG/ and s/lt_/acl_/ to avoid
dnl collision with libtool.m4.
dnl From libtool-2.4. Sets the variable with_gnu_ld to yes or no.
AC_DEFUN([AC_LIB_PROG_LD_GNU],
[AC_CACHE_CHECK([if the linker ($LD) is GNU ld], [acl_cv_prog_gnu_ld],
[# I'd rather use --version here, but apparently some GNU lds only accept -v.
case `$LD -v 2>&1 </dev/null` in
*GNU* | *'with BFD'*)
acl_cv_prog_gnu_ld=yes
;;
*)
acl_cv_prog_gnu_ld=no
;;
esac])
with_gnu_ld=$acl_cv_prog_gnu_ld
])
dnl From libtool-2.4. Sets the variable LD.
AC_DEFUN([AC_LIB_PROG_LD],
[AC_REQUIRE([AC_PROG_CC])dnl
AC_REQUIRE([AC_CANONICAL_HOST])dnl
AC_ARG_WITH([gnu-ld],
[AS_HELP_STRING([--with-gnu-ld],
[assume the C compiler uses GNU ld [default=no]])],
[test "$withval" = no || with_gnu_ld=yes],
[with_gnu_ld=no])dnl
# Prepare PATH_SEPARATOR.
# The user is always right.
if test "${PATH_SEPARATOR+set}" != set; then
# Determine PATH_SEPARATOR by trying to find /bin/sh in a PATH which
# contains only /bin. Note that ksh looks also at the FPATH variable,
# so we have to set that as well for the test.
PATH_SEPARATOR=:
(PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 \
&& { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 \
|| PATH_SEPARATOR=';'
}
fi
ac_prog=ld
if test "$GCC" = yes; then
# Check if gcc -print-prog-name=ld gives a path.
AC_MSG_CHECKING([for ld used by $CC])
case $host in
*-*-mingw*)
# gcc leaves a trailing carriage return which upsets mingw
ac_prog=`($CC -print-prog-name=ld) 2>&5 | tr -d '\015'` ;;
*)
ac_prog=`($CC -print-prog-name=ld) 2>&5` ;;
esac
case $ac_prog in
# Accept absolute paths.
[[\\/]]* | ?:[[\\/]]*)
re_direlt='/[[^/]][[^/]]*/\.\./'
# Canonicalize the pathname of ld
ac_prog=`echo "$ac_prog"| sed 's%\\\\%/%g'`
while echo "$ac_prog" | grep "$re_direlt" > /dev/null 2>&1; do
ac_prog=`echo $ac_prog| sed "s%$re_direlt%/%"`
done
test -z "$LD" && LD="$ac_prog"
;;
"")
# If it fails, then pretend we aren't using GCC.
ac_prog=ld
;;
*)
# If it is relative, then search for the first ld in PATH.
with_gnu_ld=unknown
;;
esac
elif test "$with_gnu_ld" = yes; then
AC_MSG_CHECKING([for GNU ld])
else
AC_MSG_CHECKING([for non-GNU ld])
fi
AC_CACHE_VAL([acl_cv_path_LD],
[if test -z "$LD"; then
acl_save_ifs="$IFS"; IFS=$PATH_SEPARATOR
for ac_dir in $PATH; do
IFS="$acl_save_ifs"
test -z "$ac_dir" && ac_dir=.
if test -f "$ac_dir/$ac_prog" || test -f "$ac_dir/$ac_prog$ac_exeext"; then
acl_cv_path_LD="$ac_dir/$ac_prog"
# Check to see if the program is GNU ld. I'd rather use --version,
# but apparently some variants of GNU ld only accept -v.
# Break only if it was the GNU/non-GNU ld that we prefer.
case `"$acl_cv_path_LD" -v 2>&1 </dev/null` in
*GNU* | *'with BFD'*)
test "$with_gnu_ld" != no && break
;;
*)
test "$with_gnu_ld" != yes && break
;;
esac
fi
done
IFS="$acl_save_ifs"
else
acl_cv_path_LD="$LD" # Let the user override the test with a path.
fi])
LD="$acl_cv_path_LD"
if test -n "$LD"; then
AC_MSG_RESULT([$LD])
else
AC_MSG_RESULT([no])
fi
test -z "$LD" && AC_MSG_ERROR([no acceptable ld found in \$PATH])
AC_LIB_PROG_LD_GNU
])

777
m4/lib-link.m4 Normal file
View File

@ -0,0 +1,777 @@
# lib-link.m4 serial 26 (gettext-0.18.2)
dnl Copyright (C) 2001-2016 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
dnl From Bruno Haible.
AC_PREREQ([2.54])
dnl AC_LIB_LINKFLAGS(name [, dependencies]) searches for libname and
dnl the libraries corresponding to explicit and implicit dependencies.
dnl Sets and AC_SUBSTs the LIB${NAME} and LTLIB${NAME} variables and
dnl augments the CPPFLAGS variable.
dnl Sets and AC_SUBSTs the LIB${NAME}_PREFIX variable to nonempty if libname
dnl was found in ${LIB${NAME}_PREFIX}/$acl_libdirstem.
AC_DEFUN([AC_LIB_LINKFLAGS],
[
AC_REQUIRE([AC_LIB_PREPARE_PREFIX])
AC_REQUIRE([AC_LIB_RPATH])
pushdef([Name],[m4_translit([$1],[./+-], [____])])
pushdef([NAME],[m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./+-],
[ABCDEFGHIJKLMNOPQRSTUVWXYZ____])])
AC_CACHE_CHECK([how to link with lib[]$1], [ac_cv_lib[]Name[]_libs], [
AC_LIB_LINKFLAGS_BODY([$1], [$2])
ac_cv_lib[]Name[]_libs="$LIB[]NAME"
ac_cv_lib[]Name[]_ltlibs="$LTLIB[]NAME"
ac_cv_lib[]Name[]_cppflags="$INC[]NAME"
ac_cv_lib[]Name[]_prefix="$LIB[]NAME[]_PREFIX"
])
LIB[]NAME="$ac_cv_lib[]Name[]_libs"
LTLIB[]NAME="$ac_cv_lib[]Name[]_ltlibs"
INC[]NAME="$ac_cv_lib[]Name[]_cppflags"
LIB[]NAME[]_PREFIX="$ac_cv_lib[]Name[]_prefix"
AC_LIB_APPENDTOVAR([CPPFLAGS], [$INC]NAME)
AC_SUBST([LIB]NAME)
AC_SUBST([LTLIB]NAME)
AC_SUBST([LIB]NAME[_PREFIX])
dnl Also set HAVE_LIB[]NAME so that AC_LIB_HAVE_LINKFLAGS can reuse the
dnl results of this search when this library appears as a dependency.
HAVE_LIB[]NAME=yes
popdef([NAME])
popdef([Name])
])
dnl AC_LIB_HAVE_LINKFLAGS(name, dependencies, includes, testcode, [missing-message])
dnl searches for libname and the libraries corresponding to explicit and
dnl implicit dependencies, together with the specified include files and
dnl the ability to compile and link the specified testcode. The missing-message
dnl defaults to 'no' and may contain additional hints for the user.
dnl If found, it sets and AC_SUBSTs HAVE_LIB${NAME}=yes and the LIB${NAME}
dnl and LTLIB${NAME} variables and augments the CPPFLAGS variable, and
dnl #defines HAVE_LIB${NAME} to 1. Otherwise, it sets and AC_SUBSTs
dnl HAVE_LIB${NAME}=no and LIB${NAME} and LTLIB${NAME} to empty.
dnl Sets and AC_SUBSTs the LIB${NAME}_PREFIX variable to nonempty if libname
dnl was found in ${LIB${NAME}_PREFIX}/$acl_libdirstem.
AC_DEFUN([AC_LIB_HAVE_LINKFLAGS],
[
AC_REQUIRE([AC_LIB_PREPARE_PREFIX])
AC_REQUIRE([AC_LIB_RPATH])
pushdef([Name],[m4_translit([$1],[./+-], [____])])
pushdef([NAME],[m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./+-],
[ABCDEFGHIJKLMNOPQRSTUVWXYZ____])])
dnl Search for lib[]Name and define LIB[]NAME, LTLIB[]NAME and INC[]NAME
dnl accordingly.
AC_LIB_LINKFLAGS_BODY([$1], [$2])
dnl Add $INC[]NAME to CPPFLAGS before performing the following checks,
dnl because if the user has installed lib[]Name and not disabled its use
dnl via --without-lib[]Name-prefix, he wants to use it.
ac_save_CPPFLAGS="$CPPFLAGS"
AC_LIB_APPENDTOVAR([CPPFLAGS], [$INC]NAME)
AC_CACHE_CHECK([for lib[]$1], [ac_cv_lib[]Name], [
ac_save_LIBS="$LIBS"
dnl If $LIB[]NAME contains some -l options, add it to the end of LIBS,
dnl because these -l options might require -L options that are present in
dnl LIBS. -l options benefit only from the -L options listed before it.
dnl Otherwise, add it to the front of LIBS, because it may be a static
dnl library that depends on another static library that is present in LIBS.
dnl Static libraries benefit only from the static libraries listed after
dnl it.
case " $LIB[]NAME" in
*" -l"*) LIBS="$LIBS $LIB[]NAME" ;;
*) LIBS="$LIB[]NAME $LIBS" ;;
esac
AC_LINK_IFELSE(
[AC_LANG_PROGRAM([[$3]], [[$4]])],
[ac_cv_lib[]Name=yes],
[ac_cv_lib[]Name='m4_if([$5], [], [no], [[$5]])'])
LIBS="$ac_save_LIBS"
])
if test "$ac_cv_lib[]Name" = yes; then
HAVE_LIB[]NAME=yes
AC_DEFINE([HAVE_LIB]NAME, 1, [Define if you have the lib][$1 library.])
AC_MSG_CHECKING([how to link with lib[]$1])
AC_MSG_RESULT([$LIB[]NAME])
else
HAVE_LIB[]NAME=no
dnl If $LIB[]NAME didn't lead to a usable library, we don't need
dnl $INC[]NAME either.
CPPFLAGS="$ac_save_CPPFLAGS"
LIB[]NAME=
LTLIB[]NAME=
LIB[]NAME[]_PREFIX=
fi
AC_SUBST([HAVE_LIB]NAME)
AC_SUBST([LIB]NAME)
AC_SUBST([LTLIB]NAME)
AC_SUBST([LIB]NAME[_PREFIX])
popdef([NAME])
popdef([Name])
])
dnl Determine the platform dependent parameters needed to use rpath:
dnl acl_libext,
dnl acl_shlibext,
dnl acl_libname_spec,
dnl acl_library_names_spec,
dnl acl_hardcode_libdir_flag_spec,
dnl acl_hardcode_libdir_separator,
dnl acl_hardcode_direct,
dnl acl_hardcode_minus_L.
AC_DEFUN([AC_LIB_RPATH],
[
dnl Tell automake >= 1.10 to complain if config.rpath is missing.
m4_ifdef([AC_REQUIRE_AUX_FILE], [AC_REQUIRE_AUX_FILE([config.rpath])])
AC_REQUIRE([AC_PROG_CC]) dnl we use $CC, $GCC, $LDFLAGS
AC_REQUIRE([AC_LIB_PROG_LD]) dnl we use $LD, $with_gnu_ld
AC_REQUIRE([AC_CANONICAL_HOST]) dnl we use $host
AC_REQUIRE([AC_CONFIG_AUX_DIR_DEFAULT]) dnl we use $ac_aux_dir
AC_CACHE_CHECK([for shared library run path origin], [acl_cv_rpath], [
CC="$CC" GCC="$GCC" LDFLAGS="$LDFLAGS" LD="$LD" with_gnu_ld="$with_gnu_ld" \
${CONFIG_SHELL-/bin/sh} "$ac_aux_dir/config.rpath" "$host" > conftest.sh
. ./conftest.sh
rm -f ./conftest.sh
acl_cv_rpath=done
])
wl="$acl_cv_wl"
acl_libext="$acl_cv_libext"
acl_shlibext="$acl_cv_shlibext"
acl_libname_spec="$acl_cv_libname_spec"
acl_library_names_spec="$acl_cv_library_names_spec"
acl_hardcode_libdir_flag_spec="$acl_cv_hardcode_libdir_flag_spec"
acl_hardcode_libdir_separator="$acl_cv_hardcode_libdir_separator"
acl_hardcode_direct="$acl_cv_hardcode_direct"
acl_hardcode_minus_L="$acl_cv_hardcode_minus_L"
dnl Determine whether the user wants rpath handling at all.
AC_ARG_ENABLE([rpath],
[ --disable-rpath do not hardcode runtime library paths],
:, enable_rpath=yes)
])
dnl AC_LIB_FROMPACKAGE(name, package)
dnl declares that libname comes from the given package. The configure file
dnl will then not have a --with-libname-prefix option but a
dnl --with-package-prefix option. Several libraries can come from the same
dnl package. This declaration must occur before an AC_LIB_LINKFLAGS or similar
dnl macro call that searches for libname.
AC_DEFUN([AC_LIB_FROMPACKAGE],
[
pushdef([NAME],[m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./+-],
[ABCDEFGHIJKLMNOPQRSTUVWXYZ____])])
define([acl_frompackage_]NAME, [$2])
popdef([NAME])
pushdef([PACK],[$2])
pushdef([PACKUP],[m4_translit(PACK,[abcdefghijklmnopqrstuvwxyz./+-],
[ABCDEFGHIJKLMNOPQRSTUVWXYZ____])])
define([acl_libsinpackage_]PACKUP,
m4_ifdef([acl_libsinpackage_]PACKUP, [m4_defn([acl_libsinpackage_]PACKUP)[, ]],)[lib$1])
popdef([PACKUP])
popdef([PACK])
])
dnl AC_LIB_LINKFLAGS_BODY(name [, dependencies]) searches for libname and
dnl the libraries corresponding to explicit and implicit dependencies.
dnl Sets the LIB${NAME}, LTLIB${NAME} and INC${NAME} variables.
dnl Also, sets the LIB${NAME}_PREFIX variable to nonempty if libname was found
dnl in ${LIB${NAME}_PREFIX}/$acl_libdirstem.
AC_DEFUN([AC_LIB_LINKFLAGS_BODY],
[
AC_REQUIRE([AC_LIB_PREPARE_MULTILIB])
pushdef([NAME],[m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./+-],
[ABCDEFGHIJKLMNOPQRSTUVWXYZ____])])
pushdef([PACK],[m4_ifdef([acl_frompackage_]NAME, [acl_frompackage_]NAME, lib[$1])])
pushdef([PACKUP],[m4_translit(PACK,[abcdefghijklmnopqrstuvwxyz./+-],
[ABCDEFGHIJKLMNOPQRSTUVWXYZ____])])
pushdef([PACKLIBS],[m4_ifdef([acl_frompackage_]NAME, [acl_libsinpackage_]PACKUP, lib[$1])])
dnl Autoconf >= 2.61 supports dots in --with options.
pushdef([P_A_C_K],[m4_if(m4_version_compare(m4_defn([m4_PACKAGE_VERSION]),[2.61]),[-1],[m4_translit(PACK,[.],[_])],PACK)])
dnl By default, look in $includedir and $libdir.
use_additional=yes
AC_LIB_WITH_FINAL_PREFIX([
eval additional_includedir=\"$includedir\"
eval additional_libdir=\"$libdir\"
])
AC_ARG_WITH(P_A_C_K[-prefix],
[[ --with-]]P_A_C_K[[-prefix[=DIR] search for ]PACKLIBS[ in DIR/include and DIR/lib
--without-]]P_A_C_K[[-prefix don't search for ]PACKLIBS[ in includedir and libdir]],
[
if test "X$withval" = "Xno"; then
use_additional=no
else
if test "X$withval" = "X"; then
AC_LIB_WITH_FINAL_PREFIX([
eval additional_includedir=\"$includedir\"
eval additional_libdir=\"$libdir\"
])
else
additional_includedir="$withval/include"
additional_libdir="$withval/$acl_libdirstem"
if test "$acl_libdirstem2" != "$acl_libdirstem" \
&& ! test -d "$withval/$acl_libdirstem"; then
additional_libdir="$withval/$acl_libdirstem2"
fi
fi
fi
])
dnl Search the library and its dependencies in $additional_libdir and
dnl $LDFLAGS. Using breadth-first-seach.
LIB[]NAME=
LTLIB[]NAME=
INC[]NAME=
LIB[]NAME[]_PREFIX=
dnl HAVE_LIB${NAME} is an indicator that LIB${NAME}, LTLIB${NAME} have been
dnl computed. So it has to be reset here.
HAVE_LIB[]NAME=
rpathdirs=
ltrpathdirs=
names_already_handled=
names_next_round='$1 $2'
while test -n "$names_next_round"; do
names_this_round="$names_next_round"
names_next_round=
for name in $names_this_round; do
already_handled=
for n in $names_already_handled; do
if test "$n" = "$name"; then
already_handled=yes
break
fi
done
if test -z "$already_handled"; then
names_already_handled="$names_already_handled $name"
dnl See if it was already located by an earlier AC_LIB_LINKFLAGS
dnl or AC_LIB_HAVE_LINKFLAGS call.
uppername=`echo "$name" | sed -e 'y|abcdefghijklmnopqrstuvwxyz./+-|ABCDEFGHIJKLMNOPQRSTUVWXYZ____|'`
eval value=\"\$HAVE_LIB$uppername\"
if test -n "$value"; then
if test "$value" = yes; then
eval value=\"\$LIB$uppername\"
test -z "$value" || LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$value"
eval value=\"\$LTLIB$uppername\"
test -z "$value" || LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }$value"
else
dnl An earlier call to AC_LIB_HAVE_LINKFLAGS has determined
dnl that this library doesn't exist. So just drop it.
:
fi
else
dnl Search the library lib$name in $additional_libdir and $LDFLAGS
dnl and the already constructed $LIBNAME/$LTLIBNAME.
found_dir=
found_la=
found_so=
found_a=
eval libname=\"$acl_libname_spec\" # typically: libname=lib$name
if test -n "$acl_shlibext"; then
shrext=".$acl_shlibext" # typically: shrext=.so
else
shrext=
fi
if test $use_additional = yes; then
dir="$additional_libdir"
dnl The same code as in the loop below:
dnl First look for a shared library.
if test -n "$acl_shlibext"; then
if test -f "$dir/$libname$shrext"; then
found_dir="$dir"
found_so="$dir/$libname$shrext"
else
if test "$acl_library_names_spec" = '$libname$shrext$versuffix'; then
ver=`(cd "$dir" && \
for f in "$libname$shrext".*; do echo "$f"; done \
| sed -e "s,^$libname$shrext\\\\.,," \
| sort -t '.' -n -r -k1,1 -k2,2 -k3,3 -k4,4 -k5,5 \
| sed 1q ) 2>/dev/null`
if test -n "$ver" && test -f "$dir/$libname$shrext.$ver"; then
found_dir="$dir"
found_so="$dir/$libname$shrext.$ver"
fi
else
eval library_names=\"$acl_library_names_spec\"
for f in $library_names; do
if test -f "$dir/$f"; then
found_dir="$dir"
found_so="$dir/$f"
break
fi
done
fi
fi
fi
dnl Then look for a static library.
if test "X$found_dir" = "X"; then
if test -f "$dir/$libname.$acl_libext"; then
found_dir="$dir"
found_a="$dir/$libname.$acl_libext"
fi
fi
if test "X$found_dir" != "X"; then
if test -f "$dir/$libname.la"; then
found_la="$dir/$libname.la"
fi
fi
fi
if test "X$found_dir" = "X"; then
for x in $LDFLAGS $LTLIB[]NAME; do
AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"])
case "$x" in
-L*)
dir=`echo "X$x" | sed -e 's/^X-L//'`
dnl First look for a shared library.
if test -n "$acl_shlibext"; then
if test -f "$dir/$libname$shrext"; then
found_dir="$dir"
found_so="$dir/$libname$shrext"
else
if test "$acl_library_names_spec" = '$libname$shrext$versuffix'; then
ver=`(cd "$dir" && \
for f in "$libname$shrext".*; do echo "$f"; done \
| sed -e "s,^$libname$shrext\\\\.,," \
| sort -t '.' -n -r -k1,1 -k2,2 -k3,3 -k4,4 -k5,5 \
| sed 1q ) 2>/dev/null`
if test -n "$ver" && test -f "$dir/$libname$shrext.$ver"; then
found_dir="$dir"
found_so="$dir/$libname$shrext.$ver"
fi
else
eval library_names=\"$acl_library_names_spec\"
for f in $library_names; do
if test -f "$dir/$f"; then
found_dir="$dir"
found_so="$dir/$f"
break
fi
done
fi
fi
fi
dnl Then look for a static library.
if test "X$found_dir" = "X"; then
if test -f "$dir/$libname.$acl_libext"; then
found_dir="$dir"
found_a="$dir/$libname.$acl_libext"
fi
fi
if test "X$found_dir" != "X"; then
if test -f "$dir/$libname.la"; then
found_la="$dir/$libname.la"
fi
fi
;;
esac
if test "X$found_dir" != "X"; then
break
fi
done
fi
if test "X$found_dir" != "X"; then
dnl Found the library.
LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }-L$found_dir -l$name"
if test "X$found_so" != "X"; then
dnl Linking with a shared library. We attempt to hardcode its
dnl directory into the executable's runpath, unless it's the
dnl standard /usr/lib.
if test "$enable_rpath" = no \
|| test "X$found_dir" = "X/usr/$acl_libdirstem" \
|| test "X$found_dir" = "X/usr/$acl_libdirstem2"; then
dnl No hardcoding is needed.
LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_so"
else
dnl Use an explicit option to hardcode DIR into the resulting
dnl binary.
dnl Potentially add DIR to ltrpathdirs.
dnl The ltrpathdirs will be appended to $LTLIBNAME at the end.
haveit=
for x in $ltrpathdirs; do
if test "X$x" = "X$found_dir"; then
haveit=yes
break
fi
done
if test -z "$haveit"; then
ltrpathdirs="$ltrpathdirs $found_dir"
fi
dnl The hardcoding into $LIBNAME is system dependent.
if test "$acl_hardcode_direct" = yes; then
dnl Using DIR/libNAME.so during linking hardcodes DIR into the
dnl resulting binary.
LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_so"
else
if test -n "$acl_hardcode_libdir_flag_spec" && test "$acl_hardcode_minus_L" = no; then
dnl Use an explicit option to hardcode DIR into the resulting
dnl binary.
LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_so"
dnl Potentially add DIR to rpathdirs.
dnl The rpathdirs will be appended to $LIBNAME at the end.
haveit=
for x in $rpathdirs; do
if test "X$x" = "X$found_dir"; then
haveit=yes
break
fi
done
if test -z "$haveit"; then
rpathdirs="$rpathdirs $found_dir"
fi
else
dnl Rely on "-L$found_dir".
dnl But don't add it if it's already contained in the LDFLAGS
dnl or the already constructed $LIBNAME
haveit=
for x in $LDFLAGS $LIB[]NAME; do
AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"])
if test "X$x" = "X-L$found_dir"; then
haveit=yes
break
fi
done
if test -z "$haveit"; then
LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-L$found_dir"
fi
if test "$acl_hardcode_minus_L" != no; then
dnl FIXME: Not sure whether we should use
dnl "-L$found_dir -l$name" or "-L$found_dir $found_so"
dnl here.
LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_so"
else
dnl We cannot use $acl_hardcode_runpath_var and LD_RUN_PATH
dnl here, because this doesn't fit in flags passed to the
dnl compiler. So give up. No hardcoding. This affects only
dnl very old systems.
dnl FIXME: Not sure whether we should use
dnl "-L$found_dir -l$name" or "-L$found_dir $found_so"
dnl here.
LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-l$name"
fi
fi
fi
fi
else
if test "X$found_a" != "X"; then
dnl Linking with a static library.
LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_a"
else
dnl We shouldn't come here, but anyway it's good to have a
dnl fallback.
LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-L$found_dir -l$name"
fi
fi
dnl Assume the include files are nearby.
additional_includedir=
case "$found_dir" in
*/$acl_libdirstem | */$acl_libdirstem/)
basedir=`echo "X$found_dir" | sed -e 's,^X,,' -e "s,/$acl_libdirstem/"'*$,,'`
if test "$name" = '$1'; then
LIB[]NAME[]_PREFIX="$basedir"
fi
additional_includedir="$basedir/include"
;;
*/$acl_libdirstem2 | */$acl_libdirstem2/)
basedir=`echo "X$found_dir" | sed -e 's,^X,,' -e "s,/$acl_libdirstem2/"'*$,,'`
if test "$name" = '$1'; then
LIB[]NAME[]_PREFIX="$basedir"
fi
additional_includedir="$basedir/include"
;;
esac
if test "X$additional_includedir" != "X"; then
dnl Potentially add $additional_includedir to $INCNAME.
dnl But don't add it
dnl 1. if it's the standard /usr/include,
dnl 2. if it's /usr/local/include and we are using GCC on Linux,
dnl 3. if it's already present in $CPPFLAGS or the already
dnl constructed $INCNAME,
dnl 4. if it doesn't exist as a directory.
if test "X$additional_includedir" != "X/usr/include"; then
haveit=
if test "X$additional_includedir" = "X/usr/local/include"; then
if test -n "$GCC"; then
case $host_os in
linux* | gnu* | k*bsd*-gnu) haveit=yes;;
esac
fi
fi
if test -z "$haveit"; then
for x in $CPPFLAGS $INC[]NAME; do
AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"])
if test "X$x" = "X-I$additional_includedir"; then
haveit=yes
break
fi
done
if test -z "$haveit"; then
if test -d "$additional_includedir"; then
dnl Really add $additional_includedir to $INCNAME.
INC[]NAME="${INC[]NAME}${INC[]NAME:+ }-I$additional_includedir"
fi
fi
fi
fi
fi
dnl Look for dependencies.
if test -n "$found_la"; then
dnl Read the .la file. It defines the variables
dnl dlname, library_names, old_library, dependency_libs, current,
dnl age, revision, installed, dlopen, dlpreopen, libdir.
save_libdir="$libdir"
case "$found_la" in
*/* | *\\*) . "$found_la" ;;
*) . "./$found_la" ;;
esac
libdir="$save_libdir"
dnl We use only dependency_libs.
for dep in $dependency_libs; do
case "$dep" in
-L*)
additional_libdir=`echo "X$dep" | sed -e 's/^X-L//'`
dnl Potentially add $additional_libdir to $LIBNAME and $LTLIBNAME.
dnl But don't add it
dnl 1. if it's the standard /usr/lib,
dnl 2. if it's /usr/local/lib and we are using GCC on Linux,
dnl 3. if it's already present in $LDFLAGS or the already
dnl constructed $LIBNAME,
dnl 4. if it doesn't exist as a directory.
if test "X$additional_libdir" != "X/usr/$acl_libdirstem" \
&& test "X$additional_libdir" != "X/usr/$acl_libdirstem2"; then
haveit=
if test "X$additional_libdir" = "X/usr/local/$acl_libdirstem" \
|| test "X$additional_libdir" = "X/usr/local/$acl_libdirstem2"; then
if test -n "$GCC"; then
case $host_os in
linux* | gnu* | k*bsd*-gnu) haveit=yes;;
esac
fi
fi
if test -z "$haveit"; then
haveit=
for x in $LDFLAGS $LIB[]NAME; do
AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"])
if test "X$x" = "X-L$additional_libdir"; then
haveit=yes
break
fi
done
if test -z "$haveit"; then
if test -d "$additional_libdir"; then
dnl Really add $additional_libdir to $LIBNAME.
LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-L$additional_libdir"
fi
fi
haveit=
for x in $LDFLAGS $LTLIB[]NAME; do
AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"])
if test "X$x" = "X-L$additional_libdir"; then
haveit=yes
break
fi
done
if test -z "$haveit"; then
if test -d "$additional_libdir"; then
dnl Really add $additional_libdir to $LTLIBNAME.
LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }-L$additional_libdir"
fi
fi
fi
fi
;;
-R*)
dir=`echo "X$dep" | sed -e 's/^X-R//'`
if test "$enable_rpath" != no; then
dnl Potentially add DIR to rpathdirs.
dnl The rpathdirs will be appended to $LIBNAME at the end.
haveit=
for x in $rpathdirs; do
if test "X$x" = "X$dir"; then
haveit=yes
break
fi
done
if test -z "$haveit"; then
rpathdirs="$rpathdirs $dir"
fi
dnl Potentially add DIR to ltrpathdirs.
dnl The ltrpathdirs will be appended to $LTLIBNAME at the end.
haveit=
for x in $ltrpathdirs; do
if test "X$x" = "X$dir"; then
haveit=yes
break
fi
done
if test -z "$haveit"; then
ltrpathdirs="$ltrpathdirs $dir"
fi
fi
;;
-l*)
dnl Handle this in the next round.
names_next_round="$names_next_round "`echo "X$dep" | sed -e 's/^X-l//'`
;;
*.la)
dnl Handle this in the next round. Throw away the .la's
dnl directory; it is already contained in a preceding -L
dnl option.
names_next_round="$names_next_round "`echo "X$dep" | sed -e 's,^X.*/,,' -e 's,^lib,,' -e 's,\.la$,,'`
;;
*)
dnl Most likely an immediate library name.
LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$dep"
LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }$dep"
;;
esac
done
fi
else
dnl Didn't find the library; assume it is in the system directories
dnl known to the linker and runtime loader. (All the system
dnl directories known to the linker should also be known to the
dnl runtime loader, otherwise the system is severely misconfigured.)
LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-l$name"
LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }-l$name"
fi
fi
fi
done
done
if test "X$rpathdirs" != "X"; then
if test -n "$acl_hardcode_libdir_separator"; then
dnl Weird platform: only the last -rpath option counts, the user must
dnl pass all path elements in one option. We can arrange that for a
dnl single library, but not when more than one $LIBNAMEs are used.
alldirs=
for found_dir in $rpathdirs; do
alldirs="${alldirs}${alldirs:+$acl_hardcode_libdir_separator}$found_dir"
done
dnl Note: acl_hardcode_libdir_flag_spec uses $libdir and $wl.
acl_save_libdir="$libdir"
libdir="$alldirs"
eval flag=\"$acl_hardcode_libdir_flag_spec\"
libdir="$acl_save_libdir"
LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$flag"
else
dnl The -rpath options are cumulative.
for found_dir in $rpathdirs; do
acl_save_libdir="$libdir"
libdir="$found_dir"
eval flag=\"$acl_hardcode_libdir_flag_spec\"
libdir="$acl_save_libdir"
LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$flag"
done
fi
fi
if test "X$ltrpathdirs" != "X"; then
dnl When using libtool, the option that works for both libraries and
dnl executables is -R. The -R options are cumulative.
for found_dir in $ltrpathdirs; do
LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }-R$found_dir"
done
fi
popdef([P_A_C_K])
popdef([PACKLIBS])
popdef([PACKUP])
popdef([PACK])
popdef([NAME])
])
dnl AC_LIB_APPENDTOVAR(VAR, CONTENTS) appends the elements of CONTENTS to VAR,
dnl unless already present in VAR.
dnl Works only for CPPFLAGS, not for LIB* variables because that sometimes
dnl contains two or three consecutive elements that belong together.
AC_DEFUN([AC_LIB_APPENDTOVAR],
[
for element in [$2]; do
haveit=
for x in $[$1]; do
AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"])
if test "X$x" = "X$element"; then
haveit=yes
break
fi
done
if test -z "$haveit"; then
[$1]="${[$1]}${[$1]:+ }$element"
fi
done
])
dnl For those cases where a variable contains several -L and -l options
dnl referring to unknown libraries and directories, this macro determines the
dnl necessary additional linker options for the runtime path.
dnl AC_LIB_LINKFLAGS_FROM_LIBS([LDADDVAR], [LIBSVALUE], [USE-LIBTOOL])
dnl sets LDADDVAR to linker options needed together with LIBSVALUE.
dnl If USE-LIBTOOL evaluates to non-empty, linking with libtool is assumed,
dnl otherwise linking without libtool is assumed.
AC_DEFUN([AC_LIB_LINKFLAGS_FROM_LIBS],
[
AC_REQUIRE([AC_LIB_RPATH])
AC_REQUIRE([AC_LIB_PREPARE_MULTILIB])
$1=
if test "$enable_rpath" != no; then
if test -n "$acl_hardcode_libdir_flag_spec" && test "$acl_hardcode_minus_L" = no; then
dnl Use an explicit option to hardcode directories into the resulting
dnl binary.
rpathdirs=
next=
for opt in $2; do
if test -n "$next"; then
dir="$next"
dnl No need to hardcode the standard /usr/lib.
if test "X$dir" != "X/usr/$acl_libdirstem" \
&& test "X$dir" != "X/usr/$acl_libdirstem2"; then
rpathdirs="$rpathdirs $dir"
fi
next=
else
case $opt in
-L) next=yes ;;
-L*) dir=`echo "X$opt" | sed -e 's,^X-L,,'`
dnl No need to hardcode the standard /usr/lib.
if test "X$dir" != "X/usr/$acl_libdirstem" \
&& test "X$dir" != "X/usr/$acl_libdirstem2"; then
rpathdirs="$rpathdirs $dir"
fi
next= ;;
*) next= ;;
esac
fi
done
if test "X$rpathdirs" != "X"; then
if test -n ""$3""; then
dnl libtool is used for linking. Use -R options.
for dir in $rpathdirs; do
$1="${$1}${$1:+ }-R$dir"
done
else
dnl The linker is used for linking directly.
if test -n "$acl_hardcode_libdir_separator"; then
dnl Weird platform: only the last -rpath option counts, the user
dnl must pass all path elements in one option.
alldirs=
for dir in $rpathdirs; do
alldirs="${alldirs}${alldirs:+$acl_hardcode_libdir_separator}$dir"
done
acl_save_libdir="$libdir"
libdir="$alldirs"
eval flag=\"$acl_hardcode_libdir_flag_spec\"
libdir="$acl_save_libdir"
$1="$flag"
else
dnl The -rpath options are cumulative.
for dir in $rpathdirs; do
acl_save_libdir="$libdir"
libdir="$dir"
eval flag=\"$acl_hardcode_libdir_flag_spec\"
libdir="$acl_save_libdir"
$1="${$1}${$1:+ }$flag"
done
fi
fi
fi
fi
fi
AC_SUBST([$1])
])

224
m4/lib-prefix.m4 Normal file
View File

@ -0,0 +1,224 @@
# lib-prefix.m4 serial 7 (gettext-0.18)
dnl Copyright (C) 2001-2005, 2008-2016 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
dnl From Bruno Haible.
dnl AC_LIB_ARG_WITH is synonymous to AC_ARG_WITH in autoconf-2.13, and
dnl similar to AC_ARG_WITH in autoconf 2.52...2.57 except that is doesn't
dnl require excessive bracketing.
ifdef([AC_HELP_STRING],
[AC_DEFUN([AC_LIB_ARG_WITH], [AC_ARG_WITH([$1],[[$2]],[$3],[$4])])],
[AC_DEFUN([AC_][LIB_ARG_WITH], [AC_ARG_WITH([$1],[$2],[$3],[$4])])])
dnl AC_LIB_PREFIX adds to the CPPFLAGS and LDFLAGS the flags that are needed
dnl to access previously installed libraries. The basic assumption is that
dnl a user will want packages to use other packages he previously installed
dnl with the same --prefix option.
dnl This macro is not needed if only AC_LIB_LINKFLAGS is used to locate
dnl libraries, but is otherwise very convenient.
AC_DEFUN([AC_LIB_PREFIX],
[
AC_BEFORE([$0], [AC_LIB_LINKFLAGS])
AC_REQUIRE([AC_PROG_CC])
AC_REQUIRE([AC_CANONICAL_HOST])
AC_REQUIRE([AC_LIB_PREPARE_MULTILIB])
AC_REQUIRE([AC_LIB_PREPARE_PREFIX])
dnl By default, look in $includedir and $libdir.
use_additional=yes
AC_LIB_WITH_FINAL_PREFIX([
eval additional_includedir=\"$includedir\"
eval additional_libdir=\"$libdir\"
])
AC_LIB_ARG_WITH([lib-prefix],
[ --with-lib-prefix[=DIR] search for libraries in DIR/include and DIR/lib
--without-lib-prefix don't search for libraries in includedir and libdir],
[
if test "X$withval" = "Xno"; then
use_additional=no
else
if test "X$withval" = "X"; then
AC_LIB_WITH_FINAL_PREFIX([
eval additional_includedir=\"$includedir\"
eval additional_libdir=\"$libdir\"
])
else
additional_includedir="$withval/include"
additional_libdir="$withval/$acl_libdirstem"
fi
fi
])
if test $use_additional = yes; then
dnl Potentially add $additional_includedir to $CPPFLAGS.
dnl But don't add it
dnl 1. if it's the standard /usr/include,
dnl 2. if it's already present in $CPPFLAGS,
dnl 3. if it's /usr/local/include and we are using GCC on Linux,
dnl 4. if it doesn't exist as a directory.
if test "X$additional_includedir" != "X/usr/include"; then
haveit=
for x in $CPPFLAGS; do
AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"])
if test "X$x" = "X-I$additional_includedir"; then
haveit=yes
break
fi
done
if test -z "$haveit"; then
if test "X$additional_includedir" = "X/usr/local/include"; then
if test -n "$GCC"; then
case $host_os in
linux* | gnu* | k*bsd*-gnu) haveit=yes;;
esac
fi
fi
if test -z "$haveit"; then
if test -d "$additional_includedir"; then
dnl Really add $additional_includedir to $CPPFLAGS.
CPPFLAGS="${CPPFLAGS}${CPPFLAGS:+ }-I$additional_includedir"
fi
fi
fi
fi
dnl Potentially add $additional_libdir to $LDFLAGS.
dnl But don't add it
dnl 1. if it's the standard /usr/lib,
dnl 2. if it's already present in $LDFLAGS,
dnl 3. if it's /usr/local/lib and we are using GCC on Linux,
dnl 4. if it doesn't exist as a directory.
if test "X$additional_libdir" != "X/usr/$acl_libdirstem"; then
haveit=
for x in $LDFLAGS; do
AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"])
if test "X$x" = "X-L$additional_libdir"; then
haveit=yes
break
fi
done
if test -z "$haveit"; then
if test "X$additional_libdir" = "X/usr/local/$acl_libdirstem"; then
if test -n "$GCC"; then
case $host_os in
linux*) haveit=yes;;
esac
fi
fi
if test -z "$haveit"; then
if test -d "$additional_libdir"; then
dnl Really add $additional_libdir to $LDFLAGS.
LDFLAGS="${LDFLAGS}${LDFLAGS:+ }-L$additional_libdir"
fi
fi
fi
fi
fi
])
dnl AC_LIB_PREPARE_PREFIX creates variables acl_final_prefix,
dnl acl_final_exec_prefix, containing the values to which $prefix and
dnl $exec_prefix will expand at the end of the configure script.
AC_DEFUN([AC_LIB_PREPARE_PREFIX],
[
dnl Unfortunately, prefix and exec_prefix get only finally determined
dnl at the end of configure.
if test "X$prefix" = "XNONE"; then
acl_final_prefix="$ac_default_prefix"
else
acl_final_prefix="$prefix"
fi
if test "X$exec_prefix" = "XNONE"; then
acl_final_exec_prefix='${prefix}'
else
acl_final_exec_prefix="$exec_prefix"
fi
acl_save_prefix="$prefix"
prefix="$acl_final_prefix"
eval acl_final_exec_prefix=\"$acl_final_exec_prefix\"
prefix="$acl_save_prefix"
])
dnl AC_LIB_WITH_FINAL_PREFIX([statement]) evaluates statement, with the
dnl variables prefix and exec_prefix bound to the values they will have
dnl at the end of the configure script.
AC_DEFUN([AC_LIB_WITH_FINAL_PREFIX],
[
acl_save_prefix="$prefix"
prefix="$acl_final_prefix"
acl_save_exec_prefix="$exec_prefix"
exec_prefix="$acl_final_exec_prefix"
$1
exec_prefix="$acl_save_exec_prefix"
prefix="$acl_save_prefix"
])
dnl AC_LIB_PREPARE_MULTILIB creates
dnl - a variable acl_libdirstem, containing the basename of the libdir, either
dnl "lib" or "lib64" or "lib/64",
dnl - a variable acl_libdirstem2, as a secondary possible value for
dnl acl_libdirstem, either the same as acl_libdirstem or "lib/sparcv9" or
dnl "lib/amd64".
AC_DEFUN([AC_LIB_PREPARE_MULTILIB],
[
dnl There is no formal standard regarding lib and lib64.
dnl On glibc systems, the current practice is that on a system supporting
dnl 32-bit and 64-bit instruction sets or ABIs, 64-bit libraries go under
dnl $prefix/lib64 and 32-bit libraries go under $prefix/lib. We determine
dnl the compiler's default mode by looking at the compiler's library search
dnl path. If at least one of its elements ends in /lib64 or points to a
dnl directory whose absolute pathname ends in /lib64, we assume a 64-bit ABI.
dnl Otherwise we use the default, namely "lib".
dnl On Solaris systems, the current practice is that on a system supporting
dnl 32-bit and 64-bit instruction sets or ABIs, 64-bit libraries go under
dnl $prefix/lib/64 (which is a symlink to either $prefix/lib/sparcv9 or
dnl $prefix/lib/amd64) and 32-bit libraries go under $prefix/lib.
AC_REQUIRE([AC_CANONICAL_HOST])
acl_libdirstem=lib
acl_libdirstem2=
case "$host_os" in
solaris*)
dnl See Solaris 10 Software Developer Collection > Solaris 64-bit Developer's Guide > The Development Environment
dnl <http://docs.sun.com/app/docs/doc/816-5138/dev-env?l=en&a=view>.
dnl "Portable Makefiles should refer to any library directories using the 64 symbolic link."
dnl But we want to recognize the sparcv9 or amd64 subdirectory also if the
dnl symlink is missing, so we set acl_libdirstem2 too.
AC_CACHE_CHECK([for 64-bit host], [gl_cv_solaris_64bit],
[AC_EGREP_CPP([sixtyfour bits], [
#ifdef _LP64
sixtyfour bits
#endif
], [gl_cv_solaris_64bit=yes], [gl_cv_solaris_64bit=no])
])
if test $gl_cv_solaris_64bit = yes; then
acl_libdirstem=lib/64
case "$host_cpu" in
sparc*) acl_libdirstem2=lib/sparcv9 ;;
i*86 | x86_64) acl_libdirstem2=lib/amd64 ;;
esac
fi
;;
*)
searchpath=`(LC_ALL=C $CC -print-search-dirs) 2>/dev/null | sed -n -e 's,^libraries: ,,p' | sed -e 's,^=,,'`
if test -n "$searchpath"; then
acl_save_IFS="${IFS= }"; IFS=":"
for searchdir in $searchpath; do
if test -d "$searchdir"; then
case "$searchdir" in
*/lib64/ | */lib64 ) acl_libdirstem=lib64 ;;
*/../ | */.. )
# Better ignore directories of this form. They are misleading.
;;
*) searchdir=`cd "$searchdir" && pwd`
case "$searchdir" in
*/lib64 ) acl_libdirstem=lib64 ;;
esac ;;
esac
fi
done
IFS="$acl_save_IFS"
fi
;;
esac
test -n "$acl_libdirstem2" || acl_libdirstem2="$acl_libdirstem"
])

32
m4/nls.m4 Normal file
View File

@ -0,0 +1,32 @@
# nls.m4 serial 5 (gettext-0.18)
dnl Copyright (C) 1995-2003, 2005-2006, 2008-2014, 2016 Free Software
dnl Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
dnl
dnl This file can be used in projects which are not available under
dnl the GNU General Public License or the GNU Library General Public
dnl License but which still want to provide support for the GNU gettext
dnl functionality.
dnl Please note that the actual code of the GNU gettext library is covered
dnl by the GNU Library General Public License, and the rest of the GNU
dnl gettext package is covered by the GNU General Public License.
dnl They are *not* in the public domain.
dnl Authors:
dnl Ulrich Drepper <drepper@cygnus.com>, 1995-2000.
dnl Bruno Haible <haible@clisp.cons.org>, 2000-2003.
AC_PREREQ([2.50])
AC_DEFUN([AM_NLS],
[
AC_MSG_CHECKING([whether NLS is requested])
dnl Default is enabled NLS
AC_ARG_ENABLE([nls],
[ --disable-nls do not use Native Language Support],
USE_NLS=$enableval, USE_NLS=yes)
AC_MSG_RESULT([$USE_NLS])
AC_SUBST([USE_NLS])
])

453
m4/po.m4 Normal file
View File

@ -0,0 +1,453 @@
# po.m4 serial 24 (gettext-0.19)
dnl Copyright (C) 1995-2014, 2016 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
dnl
dnl This file can be used in projects which are not available under
dnl the GNU General Public License or the GNU Library General Public
dnl License but which still want to provide support for the GNU gettext
dnl functionality.
dnl Please note that the actual code of the GNU gettext library is covered
dnl by the GNU Library General Public License, and the rest of the GNU
dnl gettext package is covered by the GNU General Public License.
dnl They are *not* in the public domain.
dnl Authors:
dnl Ulrich Drepper <drepper@cygnus.com>, 1995-2000.
dnl Bruno Haible <haible@clisp.cons.org>, 2000-2003.
AC_PREREQ([2.60])
dnl Checks for all prerequisites of the po subdirectory.
AC_DEFUN([AM_PO_SUBDIRS],
[
AC_REQUIRE([AC_PROG_MAKE_SET])dnl
AC_REQUIRE([AC_PROG_INSTALL])dnl
AC_REQUIRE([AC_PROG_MKDIR_P])dnl
AC_REQUIRE([AC_PROG_SED])dnl
AC_REQUIRE([AM_NLS])dnl
dnl Release version of the gettext macros. This is used to ensure that
dnl the gettext macros and po/Makefile.in.in are in sync.
AC_SUBST([GETTEXT_MACRO_VERSION], [0.19])
dnl Perform the following tests also if --disable-nls has been given,
dnl because they are needed for "make dist" to work.
dnl Search for GNU msgfmt in the PATH.
dnl The first test excludes Solaris msgfmt and early GNU msgfmt versions.
dnl The second test excludes FreeBSD msgfmt.
AM_PATH_PROG_WITH_TEST(MSGFMT, msgfmt,
[$ac_dir/$ac_word --statistics /dev/null >&]AS_MESSAGE_LOG_FD[ 2>&1 &&
(if $ac_dir/$ac_word --statistics /dev/null 2>&1 >/dev/null | grep usage >/dev/null; then exit 1; else exit 0; fi)],
:)
AC_PATH_PROG([GMSGFMT], [gmsgfmt], [$MSGFMT])
dnl Test whether it is GNU msgfmt >= 0.15.
changequote(,)dnl
case `$MSGFMT --version | sed 1q | sed -e 's,^[^0-9]*,,'` in
'' | 0.[0-9] | 0.[0-9].* | 0.1[0-4] | 0.1[0-4].*) MSGFMT_015=: ;;
*) MSGFMT_015=$MSGFMT ;;
esac
changequote([,])dnl
AC_SUBST([MSGFMT_015])
changequote(,)dnl
case `$GMSGFMT --version | sed 1q | sed -e 's,^[^0-9]*,,'` in
'' | 0.[0-9] | 0.[0-9].* | 0.1[0-4] | 0.1[0-4].*) GMSGFMT_015=: ;;
*) GMSGFMT_015=$GMSGFMT ;;
esac
changequote([,])dnl
AC_SUBST([GMSGFMT_015])
dnl Search for GNU xgettext 0.12 or newer in the PATH.
dnl The first test excludes Solaris xgettext and early GNU xgettext versions.
dnl The second test excludes FreeBSD xgettext.
AM_PATH_PROG_WITH_TEST(XGETTEXT, xgettext,
[$ac_dir/$ac_word --omit-header --copyright-holder= --msgid-bugs-address= /dev/null >&]AS_MESSAGE_LOG_FD[ 2>&1 &&
(if $ac_dir/$ac_word --omit-header --copyright-holder= --msgid-bugs-address= /dev/null 2>&1 >/dev/null | grep usage >/dev/null; then exit 1; else exit 0; fi)],
:)
dnl Remove leftover from FreeBSD xgettext call.
rm -f messages.po
dnl Test whether it is GNU xgettext >= 0.15.
changequote(,)dnl
case `$XGETTEXT --version | sed 1q | sed -e 's,^[^0-9]*,,'` in
'' | 0.[0-9] | 0.[0-9].* | 0.1[0-4] | 0.1[0-4].*) XGETTEXT_015=: ;;
*) XGETTEXT_015=$XGETTEXT ;;
esac
changequote([,])dnl
AC_SUBST([XGETTEXT_015])
dnl Search for GNU msgmerge 0.11 or newer in the PATH.
AM_PATH_PROG_WITH_TEST(MSGMERGE, msgmerge,
[$ac_dir/$ac_word --update -q /dev/null /dev/null >&]AS_MESSAGE_LOG_FD[ 2>&1], :)
dnl Installation directories.
dnl Autoconf >= 2.60 defines localedir. For older versions of autoconf, we
dnl have to define it here, so that it can be used in po/Makefile.
test -n "$localedir" || localedir='${datadir}/locale'
AC_SUBST([localedir])
dnl Support for AM_XGETTEXT_OPTION.
test -n "${XGETTEXT_EXTRA_OPTIONS+set}" || XGETTEXT_EXTRA_OPTIONS=
AC_SUBST([XGETTEXT_EXTRA_OPTIONS])
AC_CONFIG_COMMANDS([po-directories], [[
for ac_file in $CONFIG_FILES; do
# Support "outfile[:infile[:infile...]]"
case "$ac_file" in
*:*) ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;;
esac
# PO directories have a Makefile.in generated from Makefile.in.in.
case "$ac_file" in */Makefile.in)
# Adjust a relative srcdir.
ac_dir=`echo "$ac_file"|sed 's%/[^/][^/]*$%%'`
ac_dir_suffix=/`echo "$ac_dir"|sed 's%^\./%%'`
ac_dots=`echo "$ac_dir_suffix"|sed 's%/[^/]*%../%g'`
# In autoconf-2.13 it is called $ac_given_srcdir.
# In autoconf-2.50 it is called $srcdir.
test -n "$ac_given_srcdir" || ac_given_srcdir="$srcdir"
case "$ac_given_srcdir" in
.) top_srcdir=`echo $ac_dots|sed 's%/$%%'` ;;
/*) top_srcdir="$ac_given_srcdir" ;;
*) top_srcdir="$ac_dots$ac_given_srcdir" ;;
esac
# Treat a directory as a PO directory if and only if it has a
# POTFILES.in file. This allows packages to have multiple PO
# directories under different names or in different locations.
if test -f "$ac_given_srcdir/$ac_dir/POTFILES.in"; then
rm -f "$ac_dir/POTFILES"
test -n "$as_me" && echo "$as_me: creating $ac_dir/POTFILES" || echo "creating $ac_dir/POTFILES"
gt_tab=`printf '\t'`
cat "$ac_given_srcdir/$ac_dir/POTFILES.in" | sed -e "/^#/d" -e "/^[ ${gt_tab}]*\$/d" -e "s,.*, $top_srcdir/& \\\\," | sed -e "\$s/\(.*\) \\\\/\1/" > "$ac_dir/POTFILES"
POMAKEFILEDEPS="POTFILES.in"
# ALL_LINGUAS, POFILES, UPDATEPOFILES, DUMMYPOFILES, GMOFILES depend
# on $ac_dir but don't depend on user-specified configuration
# parameters.
if test -f "$ac_given_srcdir/$ac_dir/LINGUAS"; then
# The LINGUAS file contains the set of available languages.
if test -n "$OBSOLETE_ALL_LINGUAS"; then
test -n "$as_me" && echo "$as_me: setting ALL_LINGUAS in configure.in is obsolete" || echo "setting ALL_LINGUAS in configure.in is obsolete"
fi
ALL_LINGUAS_=`sed -e "/^#/d" -e "s/#.*//" "$ac_given_srcdir/$ac_dir/LINGUAS"`
# Hide the ALL_LINGUAS assignment from automake < 1.5.
eval 'ALL_LINGUAS''=$ALL_LINGUAS_'
POMAKEFILEDEPS="$POMAKEFILEDEPS LINGUAS"
else
# The set of available languages was given in configure.in.
# Hide the ALL_LINGUAS assignment from automake < 1.5.
eval 'ALL_LINGUAS''=$OBSOLETE_ALL_LINGUAS'
fi
# Compute POFILES
# as $(foreach lang, $(ALL_LINGUAS), $(srcdir)/$(lang).po)
# Compute UPDATEPOFILES
# as $(foreach lang, $(ALL_LINGUAS), $(lang).po-update)
# Compute DUMMYPOFILES
# as $(foreach lang, $(ALL_LINGUAS), $(lang).nop)
# Compute GMOFILES
# as $(foreach lang, $(ALL_LINGUAS), $(srcdir)/$(lang).gmo)
case "$ac_given_srcdir" in
.) srcdirpre= ;;
*) srcdirpre='$(srcdir)/' ;;
esac
POFILES=
UPDATEPOFILES=
DUMMYPOFILES=
GMOFILES=
for lang in $ALL_LINGUAS; do
POFILES="$POFILES $srcdirpre$lang.po"
UPDATEPOFILES="$UPDATEPOFILES $lang.po-update"
DUMMYPOFILES="$DUMMYPOFILES $lang.nop"
GMOFILES="$GMOFILES $srcdirpre$lang.gmo"
done
# CATALOGS depends on both $ac_dir and the user's LINGUAS
# environment variable.
INST_LINGUAS=
if test -n "$ALL_LINGUAS"; then
for presentlang in $ALL_LINGUAS; do
useit=no
if test "%UNSET%" != "$LINGUAS"; then
desiredlanguages="$LINGUAS"
else
desiredlanguages="$ALL_LINGUAS"
fi
for desiredlang in $desiredlanguages; do
# Use the presentlang catalog if desiredlang is
# a. equal to presentlang, or
# b. a variant of presentlang (because in this case,
# presentlang can be used as a fallback for messages
# which are not translated in the desiredlang catalog).
case "$desiredlang" in
"$presentlang"*) useit=yes;;
esac
done
if test $useit = yes; then
INST_LINGUAS="$INST_LINGUAS $presentlang"
fi
done
fi
CATALOGS=
if test -n "$INST_LINGUAS"; then
for lang in $INST_LINGUAS; do
CATALOGS="$CATALOGS $lang.gmo"
done
fi
test -n "$as_me" && echo "$as_me: creating $ac_dir/Makefile" || echo "creating $ac_dir/Makefile"
sed -e "/^POTFILES =/r $ac_dir/POTFILES" -e "/^# Makevars/r $ac_given_srcdir/$ac_dir/Makevars" -e "s|@POFILES@|$POFILES|g" -e "s|@UPDATEPOFILES@|$UPDATEPOFILES|g" -e "s|@DUMMYPOFILES@|$DUMMYPOFILES|g" -e "s|@GMOFILES@|$GMOFILES|g" -e "s|@CATALOGS@|$CATALOGS|g" -e "s|@POMAKEFILEDEPS@|$POMAKEFILEDEPS|g" "$ac_dir/Makefile.in" > "$ac_dir/Makefile"
for f in "$ac_given_srcdir/$ac_dir"/Rules-*; do
if test -f "$f"; then
case "$f" in
*.orig | *.bak | *~) ;;
*) cat "$f" >> "$ac_dir/Makefile" ;;
esac
fi
done
fi
;;
esac
done]],
[# Capture the value of obsolete ALL_LINGUAS because we need it to compute
# POFILES, UPDATEPOFILES, DUMMYPOFILES, GMOFILES, CATALOGS. But hide it
# from automake < 1.5.
eval 'OBSOLETE_ALL_LINGUAS''="$ALL_LINGUAS"'
# Capture the value of LINGUAS because we need it to compute CATALOGS.
LINGUAS="${LINGUAS-%UNSET%}"
])
])
dnl Postprocesses a Makefile in a directory containing PO files.
AC_DEFUN([AM_POSTPROCESS_PO_MAKEFILE],
[
# When this code is run, in config.status, two variables have already been
# set:
# - OBSOLETE_ALL_LINGUAS is the value of LINGUAS set in configure.in,
# - LINGUAS is the value of the environment variable LINGUAS at configure
# time.
changequote(,)dnl
# Adjust a relative srcdir.
ac_dir=`echo "$ac_file"|sed 's%/[^/][^/]*$%%'`
ac_dir_suffix=/`echo "$ac_dir"|sed 's%^\./%%'`
ac_dots=`echo "$ac_dir_suffix"|sed 's%/[^/]*%../%g'`
# In autoconf-2.13 it is called $ac_given_srcdir.
# In autoconf-2.50 it is called $srcdir.
test -n "$ac_given_srcdir" || ac_given_srcdir="$srcdir"
case "$ac_given_srcdir" in
.) top_srcdir=`echo $ac_dots|sed 's%/$%%'` ;;
/*) top_srcdir="$ac_given_srcdir" ;;
*) top_srcdir="$ac_dots$ac_given_srcdir" ;;
esac
# Find a way to echo strings without interpreting backslash.
if test "X`(echo '\t') 2>/dev/null`" = 'X\t'; then
gt_echo='echo'
else
if test "X`(printf '%s\n' '\t') 2>/dev/null`" = 'X\t'; then
gt_echo='printf %s\n'
else
echo_func () {
cat <<EOT
$*
EOT
}
gt_echo='echo_func'
fi
fi
# A sed script that extracts the value of VARIABLE from a Makefile.
tab=`printf '\t'`
sed_x_variable='
# Test if the hold space is empty.
x
s/P/P/
x
ta
# Yes it was empty. Look if we have the expected variable definition.
/^['"${tab}"' ]*VARIABLE['"${tab}"' ]*=/{
# Seen the first line of the variable definition.
s/^['"${tab}"' ]*VARIABLE['"${tab}"' ]*=//
ba
}
bd
:a
# Here we are processing a line from the variable definition.
# Remove comment, more precisely replace it with a space.
s/#.*$/ /
# See if the line ends in a backslash.
tb
:b
s/\\$//
# Print the line, without the trailing backslash.
p
tc
# There was no trailing backslash. The end of the variable definition is
# reached. Clear the hold space.
s/^.*$//
x
bd
:c
# A trailing backslash means that the variable definition continues in the
# next line. Put a nonempty string into the hold space to indicate this.
s/^.*$/P/
x
:d
'
changequote([,])dnl
# Set POTFILES to the value of the Makefile variable POTFILES.
sed_x_POTFILES=`$gt_echo "$sed_x_variable" | sed -e '/^ *#/d' -e 's/VARIABLE/POTFILES/g'`
POTFILES=`sed -n -e "$sed_x_POTFILES" < "$ac_file"`
# Compute POTFILES_DEPS as
# $(foreach file, $(POTFILES), $(top_srcdir)/$(file))
POTFILES_DEPS=
for file in $POTFILES; do
POTFILES_DEPS="$POTFILES_DEPS "'$(top_srcdir)/'"$file"
done
POMAKEFILEDEPS=""
if test -n "$OBSOLETE_ALL_LINGUAS"; then
test -n "$as_me" && echo "$as_me: setting ALL_LINGUAS in configure.in is obsolete" || echo "setting ALL_LINGUAS in configure.in is obsolete"
fi
if test -f "$ac_given_srcdir/$ac_dir/LINGUAS"; then
# The LINGUAS file contains the set of available languages.
ALL_LINGUAS_=`sed -e "/^#/d" -e "s/#.*//" "$ac_given_srcdir/$ac_dir/LINGUAS"`
POMAKEFILEDEPS="$POMAKEFILEDEPS LINGUAS"
else
# Set ALL_LINGUAS to the value of the Makefile variable LINGUAS.
sed_x_LINGUAS=`$gt_echo "$sed_x_variable" | sed -e '/^ *#/d' -e 's/VARIABLE/LINGUAS/g'`
ALL_LINGUAS_=`sed -n -e "$sed_x_LINGUAS" < "$ac_file"`
fi
# Hide the ALL_LINGUAS assignment from automake < 1.5.
eval 'ALL_LINGUAS''=$ALL_LINGUAS_'
# Compute POFILES
# as $(foreach lang, $(ALL_LINGUAS), $(srcdir)/$(lang).po)
# Compute UPDATEPOFILES
# as $(foreach lang, $(ALL_LINGUAS), $(lang).po-update)
# Compute DUMMYPOFILES
# as $(foreach lang, $(ALL_LINGUAS), $(lang).nop)
# Compute GMOFILES
# as $(foreach lang, $(ALL_LINGUAS), $(srcdir)/$(lang).gmo)
# Compute PROPERTIESFILES
# as $(foreach lang, $(ALL_LINGUAS), $(top_srcdir)/$(DOMAIN)_$(lang).properties)
# Compute CLASSFILES
# as $(foreach lang, $(ALL_LINGUAS), $(top_srcdir)/$(DOMAIN)_$(lang).class)
# Compute QMFILES
# as $(foreach lang, $(ALL_LINGUAS), $(srcdir)/$(lang).qm)
# Compute MSGFILES
# as $(foreach lang, $(ALL_LINGUAS), $(srcdir)/$(frob $(lang)).msg)
# Compute RESOURCESDLLFILES
# as $(foreach lang, $(ALL_LINGUAS), $(srcdir)/$(frob $(lang))/$(DOMAIN).resources.dll)
case "$ac_given_srcdir" in
.) srcdirpre= ;;
*) srcdirpre='$(srcdir)/' ;;
esac
POFILES=
UPDATEPOFILES=
DUMMYPOFILES=
GMOFILES=
PROPERTIESFILES=
CLASSFILES=
QMFILES=
MSGFILES=
RESOURCESDLLFILES=
for lang in $ALL_LINGUAS; do
POFILES="$POFILES $srcdirpre$lang.po"
UPDATEPOFILES="$UPDATEPOFILES $lang.po-update"
DUMMYPOFILES="$DUMMYPOFILES $lang.nop"
GMOFILES="$GMOFILES $srcdirpre$lang.gmo"
PROPERTIESFILES="$PROPERTIESFILES \$(top_srcdir)/\$(DOMAIN)_$lang.properties"
CLASSFILES="$CLASSFILES \$(top_srcdir)/\$(DOMAIN)_$lang.class"
QMFILES="$QMFILES $srcdirpre$lang.qm"
frobbedlang=`echo $lang | sed -e 's/\..*$//' -e 'y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/'`
MSGFILES="$MSGFILES $srcdirpre$frobbedlang.msg"
frobbedlang=`echo $lang | sed -e 's/_/-/g' -e 's/^sr-CS/sr-SP/' -e 's/@latin$/-Latn/' -e 's/@cyrillic$/-Cyrl/' -e 's/^sr-SP$/sr-SP-Latn/' -e 's/^uz-UZ$/uz-UZ-Latn/'`
RESOURCESDLLFILES="$RESOURCESDLLFILES $srcdirpre$frobbedlang/\$(DOMAIN).resources.dll"
done
# CATALOGS depends on both $ac_dir and the user's LINGUAS
# environment variable.
INST_LINGUAS=
if test -n "$ALL_LINGUAS"; then
for presentlang in $ALL_LINGUAS; do
useit=no
if test "%UNSET%" != "$LINGUAS"; then
desiredlanguages="$LINGUAS"
else
desiredlanguages="$ALL_LINGUAS"
fi
for desiredlang in $desiredlanguages; do
# Use the presentlang catalog if desiredlang is
# a. equal to presentlang, or
# b. a variant of presentlang (because in this case,
# presentlang can be used as a fallback for messages
# which are not translated in the desiredlang catalog).
case "$desiredlang" in
"$presentlang"*) useit=yes;;
esac
done
if test $useit = yes; then
INST_LINGUAS="$INST_LINGUAS $presentlang"
fi
done
fi
CATALOGS=
JAVACATALOGS=
QTCATALOGS=
TCLCATALOGS=
CSHARPCATALOGS=
if test -n "$INST_LINGUAS"; then
for lang in $INST_LINGUAS; do
CATALOGS="$CATALOGS $lang.gmo"
JAVACATALOGS="$JAVACATALOGS \$(DOMAIN)_$lang.properties"
QTCATALOGS="$QTCATALOGS $lang.qm"
frobbedlang=`echo $lang | sed -e 's/\..*$//' -e 'y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/'`
TCLCATALOGS="$TCLCATALOGS $frobbedlang.msg"
frobbedlang=`echo $lang | sed -e 's/_/-/g' -e 's/^sr-CS/sr-SP/' -e 's/@latin$/-Latn/' -e 's/@cyrillic$/-Cyrl/' -e 's/^sr-SP$/sr-SP-Latn/' -e 's/^uz-UZ$/uz-UZ-Latn/'`
CSHARPCATALOGS="$CSHARPCATALOGS $frobbedlang/\$(DOMAIN).resources.dll"
done
fi
sed -e "s|@POTFILES_DEPS@|$POTFILES_DEPS|g" -e "s|@POFILES@|$POFILES|g" -e "s|@UPDATEPOFILES@|$UPDATEPOFILES|g" -e "s|@DUMMYPOFILES@|$DUMMYPOFILES|g" -e "s|@GMOFILES@|$GMOFILES|g" -e "s|@PROPERTIESFILES@|$PROPERTIESFILES|g" -e "s|@CLASSFILES@|$CLASSFILES|g" -e "s|@QMFILES@|$QMFILES|g" -e "s|@MSGFILES@|$MSGFILES|g" -e "s|@RESOURCESDLLFILES@|$RESOURCESDLLFILES|g" -e "s|@CATALOGS@|$CATALOGS|g" -e "s|@JAVACATALOGS@|$JAVACATALOGS|g" -e "s|@QTCATALOGS@|$QTCATALOGS|g" -e "s|@TCLCATALOGS@|$TCLCATALOGS|g" -e "s|@CSHARPCATALOGS@|$CSHARPCATALOGS|g" -e 's,^#distdir:,distdir:,' < "$ac_file" > "$ac_file.tmp"
tab=`printf '\t'`
if grep -l '@TCLCATALOGS@' "$ac_file" > /dev/null; then
# Add dependencies that cannot be formulated as a simple suffix rule.
for lang in $ALL_LINGUAS; do
frobbedlang=`echo $lang | sed -e 's/\..*$//' -e 'y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/'`
cat >> "$ac_file.tmp" <<EOF
$frobbedlang.msg: $lang.po
${tab}@echo "\$(MSGFMT) -c --tcl -d \$(srcdir) -l $lang $srcdirpre$lang.po"; \
${tab}\$(MSGFMT) -c --tcl -d "\$(srcdir)" -l $lang $srcdirpre$lang.po || { rm -f "\$(srcdir)/$frobbedlang.msg"; exit 1; }
EOF
done
fi
if grep -l '@CSHARPCATALOGS@' "$ac_file" > /dev/null; then
# Add dependencies that cannot be formulated as a simple suffix rule.
for lang in $ALL_LINGUAS; do
frobbedlang=`echo $lang | sed -e 's/_/-/g' -e 's/^sr-CS/sr-SP/' -e 's/@latin$/-Latn/' -e 's/@cyrillic$/-Cyrl/' -e 's/^sr-SP$/sr-SP-Latn/' -e 's/^uz-UZ$/uz-UZ-Latn/'`
cat >> "$ac_file.tmp" <<EOF
$frobbedlang/\$(DOMAIN).resources.dll: $lang.po
${tab}@echo "\$(MSGFMT) -c --csharp -d \$(srcdir) -l $lang $srcdirpre$lang.po -r \$(DOMAIN)"; \
${tab}\$(MSGFMT) -c --csharp -d "\$(srcdir)" -l $lang $srcdirpre$lang.po -r "\$(DOMAIN)" || { rm -f "\$(srcdir)/$frobbedlang.msg"; exit 1; }
EOF
done
fi
if test -n "$POMAKEFILEDEPS"; then
cat >> "$ac_file.tmp" <<EOF
Makefile: $POMAKEFILEDEPS
EOF
fi
mv "$ac_file.tmp" "$ac_file"
])
dnl Initializes the accumulator used by AM_XGETTEXT_OPTION.
AC_DEFUN([AM_XGETTEXT_OPTION_INIT],
[
XGETTEXT_EXTRA_OPTIONS=
])
dnl Registers an option to be passed to xgettext in the po subdirectory.
AC_DEFUN([AM_XGETTEXT_OPTION],
[
AC_REQUIRE([AM_XGETTEXT_OPTION_INIT])
XGETTEXT_EXTRA_OPTIONS="$XGETTEXT_EXTRA_OPTIONS $1"
])

91
m4/progtest.m4 Normal file
View File

@ -0,0 +1,91 @@
# progtest.m4 serial 7 (gettext-0.18.2)
dnl Copyright (C) 1996-2003, 2005, 2008-2016 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
dnl
dnl This file can be used in projects which are not available under
dnl the GNU General Public License or the GNU Library General Public
dnl License but which still want to provide support for the GNU gettext
dnl functionality.
dnl Please note that the actual code of the GNU gettext library is covered
dnl by the GNU Library General Public License, and the rest of the GNU
dnl gettext package is covered by the GNU General Public License.
dnl They are *not* in the public domain.
dnl Authors:
dnl Ulrich Drepper <drepper@cygnus.com>, 1996.
AC_PREREQ([2.50])
# Search path for a program which passes the given test.
dnl AM_PATH_PROG_WITH_TEST(VARIABLE, PROG-TO-CHECK-FOR,
dnl TEST-PERFORMED-ON-FOUND_PROGRAM [, VALUE-IF-NOT-FOUND [, PATH]])
AC_DEFUN([AM_PATH_PROG_WITH_TEST],
[
# Prepare PATH_SEPARATOR.
# The user is always right.
if test "${PATH_SEPARATOR+set}" != set; then
# Determine PATH_SEPARATOR by trying to find /bin/sh in a PATH which
# contains only /bin. Note that ksh looks also at the FPATH variable,
# so we have to set that as well for the test.
PATH_SEPARATOR=:
(PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 \
&& { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 \
|| PATH_SEPARATOR=';'
}
fi
# Find out how to test for executable files. Don't use a zero-byte file,
# as systems may use methods other than mode bits to determine executability.
cat >conf$$.file <<_ASEOF
#! /bin/sh
exit 0
_ASEOF
chmod +x conf$$.file
if test -x conf$$.file >/dev/null 2>&1; then
ac_executable_p="test -x"
else
ac_executable_p="test -f"
fi
rm -f conf$$.file
# Extract the first word of "$2", so it can be a program name with args.
set dummy $2; ac_word=[$]2
AC_MSG_CHECKING([for $ac_word])
AC_CACHE_VAL([ac_cv_path_$1],
[case "[$]$1" in
[[\\/]]* | ?:[[\\/]]*)
ac_cv_path_$1="[$]$1" # Let the user override the test with a path.
;;
*)
ac_save_IFS="$IFS"; IFS=$PATH_SEPARATOR
for ac_dir in ifelse([$5], , $PATH, [$5]); do
IFS="$ac_save_IFS"
test -z "$ac_dir" && ac_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
if $ac_executable_p "$ac_dir/$ac_word$ac_exec_ext"; then
echo "$as_me: trying $ac_dir/$ac_word..." >&AS_MESSAGE_LOG_FD
if [$3]; then
ac_cv_path_$1="$ac_dir/$ac_word$ac_exec_ext"
break 2
fi
fi
done
done
IFS="$ac_save_IFS"
dnl If no 4th arg is given, leave the cache variable unset,
dnl so AC_PATH_PROGS will keep looking.
ifelse([$4], , , [ test -z "[$]ac_cv_path_$1" && ac_cv_path_$1="$4"
])dnl
;;
esac])dnl
$1="$ac_cv_path_$1"
if test ifelse([$4], , [-n "[$]$1"], ["[$]$1" != "$4"]); then
AC_MSG_RESULT([$][$1])
else
AC_MSG_RESULT([no])
fi
AC_SUBST([$1])dnl
])

215
missing Executable file
View File

@ -0,0 +1,215 @@
#! /bin/sh
# Common wrapper for a few potentially missing GNU programs.
scriptversion=2018-03-07.03; # UTC
# Copyright (C) 1996-2020 Free Software Foundation, Inc.
# Originally written by Fran,cois Pinard <pinard@iro.umontreal.ca>, 1996.
# 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. If not, see <https://www.gnu.org/licenses/>.
# As a special exception to the GNU General Public License, if you
# distribute this file as part of a program that contains a
# configuration script generated by Autoconf, you may include it under
# the same distribution terms that you use for the rest of that program.
if test $# -eq 0; then
echo 1>&2 "Try '$0 --help' for more information"
exit 1
fi
case $1 in
--is-lightweight)
# Used by our autoconf macros to check whether the available missing
# script is modern enough.
exit 0
;;
--run)
# Back-compat with the calling convention used by older automake.
shift
;;
-h|--h|--he|--hel|--help)
echo "\
$0 [OPTION]... PROGRAM [ARGUMENT]...
Run 'PROGRAM [ARGUMENT]...', returning a proper advice when this fails due
to PROGRAM being missing or too old.
Options:
-h, --help display this help and exit
-v, --version output version information and exit
Supported PROGRAM values:
aclocal autoconf autoheader autom4te automake makeinfo
bison yacc flex lex help2man
Version suffixes to PROGRAM as well as the prefixes 'gnu-', 'gnu', and
'g' are ignored when checking the name.
Send bug reports to <bug-automake@gnu.org>."
exit $?
;;
-v|--v|--ve|--ver|--vers|--versi|--versio|--version)
echo "missing $scriptversion (GNU Automake)"
exit $?
;;
-*)
echo 1>&2 "$0: unknown '$1' option"
echo 1>&2 "Try '$0 --help' for more information"
exit 1
;;
esac
# Run the given program, remember its exit status.
"$@"; st=$?
# If it succeeded, we are done.
test $st -eq 0 && exit 0
# Also exit now if we it failed (or wasn't found), and '--version' was
# passed; such an option is passed most likely to detect whether the
# program is present and works.
case $2 in --version|--help) exit $st;; esac
# Exit code 63 means version mismatch. This often happens when the user
# tries to use an ancient version of a tool on a file that requires a
# minimum version.
if test $st -eq 63; then
msg="probably too old"
elif test $st -eq 127; then
# Program was missing.
msg="missing on your system"
else
# Program was found and executed, but failed. Give up.
exit $st
fi
perl_URL=https://www.perl.org/
flex_URL=https://github.com/westes/flex
gnu_software_URL=https://www.gnu.org/software
program_details ()
{
case $1 in
aclocal|automake)
echo "The '$1' program is part of the GNU Automake package:"
echo "<$gnu_software_URL/automake>"
echo "It also requires GNU Autoconf, GNU m4 and Perl in order to run:"
echo "<$gnu_software_URL/autoconf>"
echo "<$gnu_software_URL/m4/>"
echo "<$perl_URL>"
;;
autoconf|autom4te|autoheader)
echo "The '$1' program is part of the GNU Autoconf package:"
echo "<$gnu_software_URL/autoconf/>"
echo "It also requires GNU m4 and Perl in order to run:"
echo "<$gnu_software_URL/m4/>"
echo "<$perl_URL>"
;;
esac
}
give_advice ()
{
# Normalize program name to check for.
normalized_program=`echo "$1" | sed '
s/^gnu-//; t
s/^gnu//; t
s/^g//; t'`
printf '%s\n' "'$1' is $msg."
configure_deps="'configure.ac' or m4 files included by 'configure.ac'"
case $normalized_program in
autoconf*)
echo "You should only need it if you modified 'configure.ac',"
echo "or m4 files included by it."
program_details 'autoconf'
;;
autoheader*)
echo "You should only need it if you modified 'acconfig.h' or"
echo "$configure_deps."
program_details 'autoheader'
;;
automake*)
echo "You should only need it if you modified 'Makefile.am' or"
echo "$configure_deps."
program_details 'automake'
;;
aclocal*)
echo "You should only need it if you modified 'acinclude.m4' or"
echo "$configure_deps."
program_details 'aclocal'
;;
autom4te*)
echo "You might have modified some maintainer files that require"
echo "the 'autom4te' program to be rebuilt."
program_details 'autom4te'
;;
bison*|yacc*)
echo "You should only need it if you modified a '.y' file."
echo "You may want to install the GNU Bison package:"
echo "<$gnu_software_URL/bison/>"
;;
lex*|flex*)
echo "You should only need it if you modified a '.l' file."
echo "You may want to install the Fast Lexical Analyzer package:"
echo "<$flex_URL>"
;;
help2man*)
echo "You should only need it if you modified a dependency" \
"of a man page."
echo "You may want to install the GNU Help2man package:"
echo "<$gnu_software_URL/help2man/>"
;;
makeinfo*)
echo "You should only need it if you modified a '.texi' file, or"
echo "any other file indirectly affecting the aspect of the manual."
echo "You might want to install the Texinfo package:"
echo "<$gnu_software_URL/texinfo/>"
echo "The spurious makeinfo call might also be the consequence of"
echo "using a buggy 'make' (AIX, DU, IRIX), in which case you might"
echo "want to install GNU make:"
echo "<$gnu_software_URL/make/>"
;;
*)
echo "You might have modified some files without having the proper"
echo "tools for further handling them. Check the 'README' file, it"
echo "often tells you about the needed prerequisites for installing"
echo "this package. You may also peek at any GNU archive site, in"
echo "case some other package contains this missing '$1' program."
;;
esac
}
give_advice "$1" | sed -e '1s/^/WARNING: /' \
-e '2,$s/^/ /' >&2
# Propagate the correct exit status (expected to be 127 for a program
# not found, 63 for a program that failed due to version mismatch).
exit $st
# Local variables:
# eval: (add-hook 'before-save-hook 'time-stamp)
# time-stamp-start: "scriptversion="
# time-stamp-format: "%:y-%02m-%02d.%02H"
# time-stamp-time-zone: "UTC0"
# time-stamp-end: "; # UTC"
# End:

12
po/ChangeLog Normal file
View File

@ -0,0 +1,12 @@
2019-12-26 gettextize <bug-gnu-gettext@gnu.org>
* Makefile.in.in: New file, from gettext-0.19.8.1.
* Rules-quot: New file, from gettext-0.19.8.1.
* boldquot.sed: New file, from gettext-0.19.8.1.
* en@boldquot.header: New file, from gettext-0.19.8.1.
* en@quot.header: New file, from gettext-0.19.8.1.
* insert-header.sin: New file, from gettext-0.19.8.1.
* quot.sed: New file, from gettext-0.19.8.1.
* remove-potcdate.sin: New file, from gettext-0.19.8.1.
* POTFILES.in: New file.

2
po/LINGUAS Normal file
View File

@ -0,0 +1,2 @@
# Set of available languages.
en@boldquot en@quot it

483
po/Makefile.in.in Normal file
View File

@ -0,0 +1,483 @@
# Makefile for PO directory in any package using GNU gettext.
# Copyright (C) 1995-1997, 2000-2007, 2009-2010 by Ulrich Drepper <drepper@gnu.ai.mit.edu>
#
# 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.
#
# Origin: gettext-0.19.8
GETTEXT_MACRO_VERSION = 0.19
PACKAGE = @PACKAGE@
VERSION = @VERSION@
PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
SED = @SED@
SHELL = /bin/sh
@SET_MAKE@
srcdir = @srcdir@
top_srcdir = @top_srcdir@
VPATH = @srcdir@
prefix = @prefix@
exec_prefix = @exec_prefix@
datarootdir = @datarootdir@
datadir = @datadir@
localedir = @localedir@
gettextsrcdir = $(datadir)/gettext/po
INSTALL = @INSTALL@
INSTALL_DATA = @INSTALL_DATA@
# We use $(mkdir_p).
# In automake <= 1.9.x, $(mkdir_p) is defined either as "mkdir -p --" or as
# "$(mkinstalldirs)" or as "$(install_sh) -d". For these automake versions,
# @install_sh@ does not start with $(SHELL), so we add it.
# In automake >= 1.10, @mkdir_p@ is derived from ${MKDIR_P}, which is defined
# either as "/path/to/mkdir -p" or ".../install-sh -c -d". For these automake
# versions, $(mkinstalldirs) and $(install_sh) are unused.
mkinstalldirs = $(SHELL) @install_sh@ -d
install_sh = $(SHELL) @install_sh@
MKDIR_P = @MKDIR_P@
mkdir_p = @mkdir_p@
# When building gettext-tools, we prefer to use the built programs
# rather than installed programs. However, we can't do that when we
# are cross compiling.
CROSS_COMPILING = @CROSS_COMPILING@
GMSGFMT_ = @GMSGFMT@
GMSGFMT_no = @GMSGFMT@
GMSGFMT_yes = @GMSGFMT_015@
GMSGFMT = $(GMSGFMT_$(USE_MSGCTXT))
MSGFMT_ = @MSGFMT@
MSGFMT_no = @MSGFMT@
MSGFMT_yes = @MSGFMT_015@
MSGFMT = $(MSGFMT_$(USE_MSGCTXT))
XGETTEXT_ = @XGETTEXT@
XGETTEXT_no = @XGETTEXT@
XGETTEXT_yes = @XGETTEXT_015@
XGETTEXT = $(XGETTEXT_$(USE_MSGCTXT))
MSGMERGE = msgmerge
MSGMERGE_UPDATE = @MSGMERGE@ --update
MSGINIT = msginit
MSGCONV = msgconv
MSGFILTER = msgfilter
POFILES = @POFILES@
GMOFILES = @GMOFILES@
UPDATEPOFILES = @UPDATEPOFILES@
DUMMYPOFILES = @DUMMYPOFILES@
DISTFILES.common = Makefile.in.in remove-potcdate.sin \
$(DISTFILES.common.extra1) $(DISTFILES.common.extra2) $(DISTFILES.common.extra3)
DISTFILES = $(DISTFILES.common) Makevars POTFILES.in \
$(POFILES) $(GMOFILES) \
$(DISTFILES.extra1) $(DISTFILES.extra2) $(DISTFILES.extra3)
POTFILES = \
CATALOGS = @CATALOGS@
POFILESDEPS_ = $(srcdir)/$(DOMAIN).pot
POFILESDEPS_yes = $(POFILESDEPS_)
POFILESDEPS_no =
POFILESDEPS = $(POFILESDEPS_$(PO_DEPENDS_ON_POT))
DISTFILESDEPS_ = update-po
DISTFILESDEPS_yes = $(DISTFILESDEPS_)
DISTFILESDEPS_no =
DISTFILESDEPS = $(DISTFILESDEPS_$(DIST_DEPENDS_ON_UPDATE_PO))
# Makevars gets inserted here. (Don't remove this line!)
.SUFFIXES:
.SUFFIXES: .po .gmo .mo .sed .sin .nop .po-create .po-update
.po.mo:
@echo "$(MSGFMT) -c -o $@ $<"; \
$(MSGFMT) -c -o t-$@ $< && mv t-$@ $@
.po.gmo:
@lang=`echo $* | sed -e 's,.*/,,'`; \
test "$(srcdir)" = . && cdcmd="" || cdcmd="cd $(srcdir) && "; \
echo "$${cdcmd}rm -f $${lang}.gmo && $(GMSGFMT) -c --statistics --verbose -o $${lang}.gmo $${lang}.po"; \
cd $(srcdir) && rm -f $${lang}.gmo && $(GMSGFMT) -c --statistics --verbose -o t-$${lang}.gmo $${lang}.po && mv t-$${lang}.gmo $${lang}.gmo
.sin.sed:
sed -e '/^#/d' $< > t-$@
mv t-$@ $@
all: all-@USE_NLS@
all-yes: stamp-po
all-no:
# Ensure that the gettext macros and this Makefile.in.in are in sync.
CHECK_MACRO_VERSION = \
test "$(GETTEXT_MACRO_VERSION)" = "@GETTEXT_MACRO_VERSION@" \
|| { echo "*** error: gettext infrastructure mismatch: using a Makefile.in.in from gettext version $(GETTEXT_MACRO_VERSION) but the autoconf macros are from gettext version @GETTEXT_MACRO_VERSION@" 1>&2; \
exit 1; \
}
# $(srcdir)/$(DOMAIN).pot is only created when needed. When xgettext finds no
# internationalized messages, no $(srcdir)/$(DOMAIN).pot is created (because
# we don't want to bother translators with empty POT files). We assume that
# LINGUAS is empty in this case, i.e. $(POFILES) and $(GMOFILES) are empty.
# In this case, stamp-po is a nop (i.e. a phony target).
# stamp-po is a timestamp denoting the last time at which the CATALOGS have
# been loosely updated. Its purpose is that when a developer or translator
# checks out the package via CVS, and the $(DOMAIN).pot file is not in CVS,
# "make" will update the $(DOMAIN).pot and the $(CATALOGS), but subsequent
# invocations of "make" will do nothing. This timestamp would not be necessary
# if updating the $(CATALOGS) would always touch them; however, the rule for
# $(POFILES) has been designed to not touch files that don't need to be
# changed.
stamp-po: $(srcdir)/$(DOMAIN).pot
@$(CHECK_MACRO_VERSION)
test ! -f $(srcdir)/$(DOMAIN).pot || \
test -z "$(GMOFILES)" || $(MAKE) $(GMOFILES)
@test ! -f $(srcdir)/$(DOMAIN).pot || { \
echo "touch stamp-po" && \
echo timestamp > stamp-poT && \
mv stamp-poT stamp-po; \
}
# Note: Target 'all' must not depend on target '$(DOMAIN).pot-update',
# otherwise packages like GCC can not be built if only parts of the source
# have been downloaded.
# This target rebuilds $(DOMAIN).pot; it is an expensive operation.
# Note that $(DOMAIN).pot is not touched if it doesn't need to be changed.
# The determination of whether the package xyz is a GNU one is based on the
# heuristic whether some file in the top level directory mentions "GNU xyz".
# If GNU 'find' is available, we avoid grepping through monster files.
$(DOMAIN).pot-update: $(POTFILES) $(srcdir)/POTFILES.in remove-potcdate.sed
package_gnu="$(PACKAGE_GNU)"; \
test -n "$$package_gnu" || { \
if { if (LC_ALL=C find --version) 2>/dev/null | grep GNU >/dev/null; then \
LC_ALL=C find -L $(top_srcdir) -maxdepth 1 -type f \
-size -10000000c -exec grep 'GNU @PACKAGE@' \
/dev/null '{}' ';' 2>/dev/null; \
else \
LC_ALL=C grep 'GNU @PACKAGE@' $(top_srcdir)/* 2>/dev/null; \
fi; \
} | grep -v 'libtool:' >/dev/null; then \
package_gnu=yes; \
else \
package_gnu=no; \
fi; \
}; \
if test "$$package_gnu" = "yes"; then \
package_prefix='GNU '; \
else \
package_prefix=''; \
fi; \
if test -n '$(MSGID_BUGS_ADDRESS)' || test '$(PACKAGE_BUGREPORT)' = '@'PACKAGE_BUGREPORT'@'; then \
msgid_bugs_address='$(MSGID_BUGS_ADDRESS)'; \
else \
msgid_bugs_address='$(PACKAGE_BUGREPORT)'; \
fi; \
case `$(XGETTEXT) --version | sed 1q | sed -e 's,^[^0-9]*,,'` in \
'' | 0.[0-9] | 0.[0-9].* | 0.1[0-5] | 0.1[0-5].* | 0.16 | 0.16.[0-1]*) \
$(XGETTEXT) --default-domain=$(DOMAIN) --directory=$(top_srcdir) \
--add-comments=TRANSLATORS: $(XGETTEXT_OPTIONS) @XGETTEXT_EXTRA_OPTIONS@ \
--files-from=$(srcdir)/POTFILES.in \
--copyright-holder='$(COPYRIGHT_HOLDER)' \
--msgid-bugs-address="$$msgid_bugs_address" \
;; \
*) \
$(XGETTEXT) --default-domain=$(DOMAIN) --directory=$(top_srcdir) \
--add-comments=TRANSLATORS: $(XGETTEXT_OPTIONS) @XGETTEXT_EXTRA_OPTIONS@ \
--files-from=$(srcdir)/POTFILES.in \
--copyright-holder='$(COPYRIGHT_HOLDER)' \
--package-name="$${package_prefix}@PACKAGE@" \
--package-version='@VERSION@' \
--msgid-bugs-address="$$msgid_bugs_address" \
;; \
esac
test ! -f $(DOMAIN).po || { \
if test -f $(srcdir)/$(DOMAIN).pot-header; then \
sed -e '1,/^#$$/d' < $(DOMAIN).po > $(DOMAIN).1po && \
cat $(srcdir)/$(DOMAIN).pot-header $(DOMAIN).1po > $(DOMAIN).po; \
rm -f $(DOMAIN).1po; \
fi; \
if test -f $(srcdir)/$(DOMAIN).pot; then \
sed -f remove-potcdate.sed < $(srcdir)/$(DOMAIN).pot > $(DOMAIN).1po && \
sed -f remove-potcdate.sed < $(DOMAIN).po > $(DOMAIN).2po && \
if cmp $(DOMAIN).1po $(DOMAIN).2po >/dev/null 2>&1; then \
rm -f $(DOMAIN).1po $(DOMAIN).2po $(DOMAIN).po; \
else \
rm -f $(DOMAIN).1po $(DOMAIN).2po $(srcdir)/$(DOMAIN).pot && \
mv $(DOMAIN).po $(srcdir)/$(DOMAIN).pot; \
fi; \
else \
mv $(DOMAIN).po $(srcdir)/$(DOMAIN).pot; \
fi; \
}
# This rule has no dependencies: we don't need to update $(DOMAIN).pot at
# every "make" invocation, only create it when it is missing.
# Only "make $(DOMAIN).pot-update" or "make dist" will force an update.
$(srcdir)/$(DOMAIN).pot:
$(MAKE) $(DOMAIN).pot-update
# This target rebuilds a PO file if $(DOMAIN).pot has changed.
# Note that a PO file is not touched if it doesn't need to be changed.
$(POFILES): $(POFILESDEPS)
@lang=`echo $@ | sed -e 's,.*/,,' -e 's/\.po$$//'`; \
if test -f "$(srcdir)/$${lang}.po"; then \
test -f $(srcdir)/$(DOMAIN).pot || $(MAKE) $(srcdir)/$(DOMAIN).pot; \
test "$(srcdir)" = . && cdcmd="" || cdcmd="cd $(srcdir) && "; \
echo "$${cdcmd}$(MSGMERGE_UPDATE) $(MSGMERGE_OPTIONS) --lang=$${lang} $${lang}.po $(DOMAIN).pot"; \
cd $(srcdir) \
&& { case `$(MSGMERGE) --version | sed 1q | sed -e 's,^[^0-9]*,,'` in \
'' | 0.[0-9] | 0.[0-9].* | 0.1[0-7] | 0.1[0-7].*) \
$(MSGMERGE_UPDATE) $(MSGMERGE_OPTIONS) $${lang}.po $(DOMAIN).pot;; \
*) \
$(MSGMERGE_UPDATE) $(MSGMERGE_OPTIONS) --lang=$${lang} $${lang}.po $(DOMAIN).pot;; \
esac; \
}; \
else \
$(MAKE) $${lang}.po-create; \
fi
install: install-exec install-data
install-exec:
install-data: install-data-@USE_NLS@
if test "$(PACKAGE)" = "gettext-tools"; then \
$(mkdir_p) $(DESTDIR)$(gettextsrcdir); \
for file in $(DISTFILES.common) Makevars.template; do \
$(INSTALL_DATA) $(srcdir)/$$file \
$(DESTDIR)$(gettextsrcdir)/$$file; \
done; \
for file in Makevars; do \
rm -f $(DESTDIR)$(gettextsrcdir)/$$file; \
done; \
else \
: ; \
fi
install-data-no: all
install-data-yes: all
@catalogs='$(CATALOGS)'; \
for cat in $$catalogs; do \
cat=`basename $$cat`; \
lang=`echo $$cat | sed -e 's/\.gmo$$//'`; \
dir=$(localedir)/$$lang/LC_MESSAGES; \
$(mkdir_p) $(DESTDIR)$$dir; \
if test -r $$cat; then realcat=$$cat; else realcat=$(srcdir)/$$cat; fi; \
$(INSTALL_DATA) $$realcat $(DESTDIR)$$dir/$(DOMAIN).mo; \
echo "installing $$realcat as $(DESTDIR)$$dir/$(DOMAIN).mo"; \
for lc in '' $(EXTRA_LOCALE_CATEGORIES); do \
if test -n "$$lc"; then \
if (cd $(DESTDIR)$(localedir)/$$lang && LC_ALL=C ls -l -d $$lc 2>/dev/null) | grep ' -> ' >/dev/null; then \
link=`cd $(DESTDIR)$(localedir)/$$lang && LC_ALL=C ls -l -d $$lc | sed -e 's/^.* -> //'`; \
mv $(DESTDIR)$(localedir)/$$lang/$$lc $(DESTDIR)$(localedir)/$$lang/$$lc.old; \
mkdir $(DESTDIR)$(localedir)/$$lang/$$lc; \
(cd $(DESTDIR)$(localedir)/$$lang/$$lc.old && \
for file in *; do \
if test -f $$file; then \
ln -s ../$$link/$$file $(DESTDIR)$(localedir)/$$lang/$$lc/$$file; \
fi; \
done); \
rm -f $(DESTDIR)$(localedir)/$$lang/$$lc.old; \
else \
if test -d $(DESTDIR)$(localedir)/$$lang/$$lc; then \
:; \
else \
rm -f $(DESTDIR)$(localedir)/$$lang/$$lc; \
mkdir $(DESTDIR)$(localedir)/$$lang/$$lc; \
fi; \
fi; \
rm -f $(DESTDIR)$(localedir)/$$lang/$$lc/$(DOMAIN).mo; \
ln -s ../LC_MESSAGES/$(DOMAIN).mo $(DESTDIR)$(localedir)/$$lang/$$lc/$(DOMAIN).mo 2>/dev/null || \
ln $(DESTDIR)$(localedir)/$$lang/LC_MESSAGES/$(DOMAIN).mo $(DESTDIR)$(localedir)/$$lang/$$lc/$(DOMAIN).mo 2>/dev/null || \
cp -p $(DESTDIR)$(localedir)/$$lang/LC_MESSAGES/$(DOMAIN).mo $(DESTDIR)$(localedir)/$$lang/$$lc/$(DOMAIN).mo; \
echo "installing $$realcat link as $(DESTDIR)$(localedir)/$$lang/$$lc/$(DOMAIN).mo"; \
fi; \
done; \
done
install-strip: install
installdirs: installdirs-exec installdirs-data
installdirs-exec:
installdirs-data: installdirs-data-@USE_NLS@
if test "$(PACKAGE)" = "gettext-tools"; then \
$(mkdir_p) $(DESTDIR)$(gettextsrcdir); \
else \
: ; \
fi
installdirs-data-no:
installdirs-data-yes:
@catalogs='$(CATALOGS)'; \
for cat in $$catalogs; do \
cat=`basename $$cat`; \
lang=`echo $$cat | sed -e 's/\.gmo$$//'`; \
dir=$(localedir)/$$lang/LC_MESSAGES; \
$(mkdir_p) $(DESTDIR)$$dir; \
for lc in '' $(EXTRA_LOCALE_CATEGORIES); do \
if test -n "$$lc"; then \
if (cd $(DESTDIR)$(localedir)/$$lang && LC_ALL=C ls -l -d $$lc 2>/dev/null) | grep ' -> ' >/dev/null; then \
link=`cd $(DESTDIR)$(localedir)/$$lang && LC_ALL=C ls -l -d $$lc | sed -e 's/^.* -> //'`; \
mv $(DESTDIR)$(localedir)/$$lang/$$lc $(DESTDIR)$(localedir)/$$lang/$$lc.old; \
mkdir $(DESTDIR)$(localedir)/$$lang/$$lc; \
(cd $(DESTDIR)$(localedir)/$$lang/$$lc.old && \
for file in *; do \
if test -f $$file; then \
ln -s ../$$link/$$file $(DESTDIR)$(localedir)/$$lang/$$lc/$$file; \
fi; \
done); \
rm -f $(DESTDIR)$(localedir)/$$lang/$$lc.old; \
else \
if test -d $(DESTDIR)$(localedir)/$$lang/$$lc; then \
:; \
else \
rm -f $(DESTDIR)$(localedir)/$$lang/$$lc; \
mkdir $(DESTDIR)$(localedir)/$$lang/$$lc; \
fi; \
fi; \
fi; \
done; \
done
# Define this as empty until I found a useful application.
installcheck:
uninstall: uninstall-exec uninstall-data
uninstall-exec:
uninstall-data: uninstall-data-@USE_NLS@
if test "$(PACKAGE)" = "gettext-tools"; then \
for file in $(DISTFILES.common) Makevars.template; do \
rm -f $(DESTDIR)$(gettextsrcdir)/$$file; \
done; \
else \
: ; \
fi
uninstall-data-no:
uninstall-data-yes:
catalogs='$(CATALOGS)'; \
for cat in $$catalogs; do \
cat=`basename $$cat`; \
lang=`echo $$cat | sed -e 's/\.gmo$$//'`; \
for lc in LC_MESSAGES $(EXTRA_LOCALE_CATEGORIES); do \
rm -f $(DESTDIR)$(localedir)/$$lang/$$lc/$(DOMAIN).mo; \
done; \
done
check: all
info dvi ps pdf html tags TAGS ctags CTAGS ID:
mostlyclean:
rm -f remove-potcdate.sed
rm -f stamp-poT
rm -f core core.* $(DOMAIN).po $(DOMAIN).1po $(DOMAIN).2po *.new.po
rm -fr *.o
clean: mostlyclean
distclean: clean
rm -f Makefile Makefile.in POTFILES *.mo
maintainer-clean: distclean
@echo "This command is intended for maintainers to use;"
@echo "it deletes files that may require special tools to rebuild."
rm -f stamp-po $(GMOFILES)
distdir = $(top_builddir)/$(PACKAGE)-$(VERSION)/$(subdir)
dist distdir:
test -z "$(DISTFILESDEPS)" || $(MAKE) $(DISTFILESDEPS)
@$(MAKE) dist2
# This is a separate target because 'update-po' must be executed before.
dist2: stamp-po $(DISTFILES)
dists="$(DISTFILES)"; \
if test "$(PACKAGE)" = "gettext-tools"; then \
dists="$$dists Makevars.template"; \
fi; \
if test -f $(srcdir)/$(DOMAIN).pot; then \
dists="$$dists $(DOMAIN).pot stamp-po"; \
fi; \
if test -f $(srcdir)/ChangeLog; then \
dists="$$dists ChangeLog"; \
fi; \
for i in 0 1 2 3 4 5 6 7 8 9; do \
if test -f $(srcdir)/ChangeLog.$$i; then \
dists="$$dists ChangeLog.$$i"; \
fi; \
done; \
if test -f $(srcdir)/LINGUAS; then dists="$$dists LINGUAS"; fi; \
for file in $$dists; do \
if test -f $$file; then \
cp -p $$file $(distdir) || exit 1; \
else \
cp -p $(srcdir)/$$file $(distdir) || exit 1; \
fi; \
done
update-po: Makefile
$(MAKE) $(DOMAIN).pot-update
test -z "$(UPDATEPOFILES)" || $(MAKE) $(UPDATEPOFILES)
$(MAKE) update-gmo
# General rule for creating PO files.
.nop.po-create:
@lang=`echo $@ | sed -e 's/\.po-create$$//'`; \
echo "File $$lang.po does not exist. If you are a translator, you can create it through 'msginit'." 1>&2; \
exit 1
# General rule for updating PO files.
.nop.po-update:
@lang=`echo $@ | sed -e 's/\.po-update$$//'`; \
if test "$(PACKAGE)" = "gettext-tools" && test "$(CROSS_COMPILING)" != "yes"; then PATH=`pwd`/../src:$$PATH; fi; \
tmpdir=`pwd`; \
echo "$$lang:"; \
test "$(srcdir)" = . && cdcmd="" || cdcmd="cd $(srcdir) && "; \
echo "$${cdcmd}$(MSGMERGE) $(MSGMERGE_OPTIONS) --lang=$$lang $$lang.po $(DOMAIN).pot -o $$lang.new.po"; \
cd $(srcdir); \
if { case `$(MSGMERGE) --version | sed 1q | sed -e 's,^[^0-9]*,,'` in \
'' | 0.[0-9] | 0.[0-9].* | 0.1[0-7] | 0.1[0-7].*) \
$(MSGMERGE) $(MSGMERGE_OPTIONS) -o $$tmpdir/$$lang.new.po $$lang.po $(DOMAIN).pot;; \
*) \
$(MSGMERGE) $(MSGMERGE_OPTIONS) --lang=$$lang -o $$tmpdir/$$lang.new.po $$lang.po $(DOMAIN).pot;; \
esac; \
}; then \
if cmp $$lang.po $$tmpdir/$$lang.new.po >/dev/null 2>&1; then \
rm -f $$tmpdir/$$lang.new.po; \
else \
if mv -f $$tmpdir/$$lang.new.po $$lang.po; then \
:; \
else \
echo "msgmerge for $$lang.po failed: cannot move $$tmpdir/$$lang.new.po to $$lang.po" 1>&2; \
exit 1; \
fi; \
fi; \
else \
echo "msgmerge for $$lang.po failed!" 1>&2; \
rm -f $$tmpdir/$$lang.new.po; \
fi
$(DUMMYPOFILES):
update-gmo: Makefile $(GMOFILES)
@:
# Recreate Makefile by invoking config.status. Explicitly invoke the shell,
# because execution permission bits may not work on the current file system.
# Use @SHELL@, which is the shell determined by autoconf for the use by its
# scripts, not $(SHELL) which is hardwired to /bin/sh and may be deficient.
Makefile: Makefile.in.in Makevars $(top_builddir)/config.status @POMAKEFILEDEPS@
cd $(top_builddir) \
&& @SHELL@ ./config.status $(subdir)/$@.in po-directories
force:
# Tell versions [3.59,3.63) of GNU make not to export all variables.
# Otherwise a system limit (for SysV at least) may be exceeded.
.NOEXPORT:

78
po/Makevars Normal file
View File

@ -0,0 +1,78 @@
# Makefile variables for PO directory in any package using GNU gettext.
# Usually the message domain is the same as the package name.
DOMAIN = $(PACKAGE)
# These two variables depend on the location of this directory.
subdir = po
top_builddir = ..
# These options get passed to xgettext.
XGETTEXT_OPTIONS = --keyword=_ --keyword=n_:1,2 --language=Lisp
# This is the copyright holder that gets inserted into the header of the
# $(DOMAIN).pot file. Set this to the copyright holder of the surrounding
# package. (Note that the msgstr strings, extracted from the package's
# sources, belong to the copyright holder of the package.) Translators are
# expected to transfer the copyright for their translations to this person
# or entity, or to disclaim their copyright. The empty string stands for
# the public domain; in this case the translators are expected to disclaim
# their copyright.
COPYRIGHT_HOLDER = cage
# This tells whether or not to prepend "GNU " prefix to the package
# name that gets inserted into the header of the $(DOMAIN).pot file.
# Possible values are "yes", "no", or empty. If it is empty, try to
# detect it automatically by scanning the files in $(top_srcdir) for
# "GNU packagename" string.
PACKAGE_GNU =
# This is the email address or URL to which the translators shall report
# bugs in the untranslated strings:
# - Strings which are not entire sentences, see the maintainer guidelines
# in the GNU gettext documentation, section 'Preparing Strings'.
# - Strings which use unclear terms or require additional context to be
# understood.
# - Strings which make invalid assumptions about notation of date, time or
# money.
# - Pluralisation problems.
# - Incorrect English spelling.
# - Incorrect formatting.
# It can be your email address, or a mailing list address where translators
# can write to without being subscribed, or the URL of a web page through
# which the translators can contact you.
MSGID_BUGS_ADDRESS = https://notabug.org/cage/tinmop/
# This is the list of locale categories, beyond LC_MESSAGES, for which the
# message catalogs shall be used. It is usually empty.
EXTRA_LOCALE_CATEGORIES =
# This tells whether the $(DOMAIN).pot file contains messages with an 'msgctxt'
# context. Possible values are "yes" and "no". Set this to yes if the
# package uses functions taking also a message context, like pgettext(), or
# if in $(XGETTEXT_OPTIONS) you define keywords with a context argument.
USE_MSGCTXT = no
# These options get passed to msgmerge.
# Useful options are in particular:
# --previous to keep previous msgids of translated messages,
# --quiet to reduce the verbosity.
MSGMERGE_OPTIONS =
# These options get passed to msginit.
# If you want to disable line wrapping when writing PO files, add
# --no-wrap to MSGMERGE_OPTIONS, XGETTEXT_OPTIONS, and
# MSGINIT_OPTIONS.
MSGINIT_OPTIONS =
# This tells whether or not to regenerate a PO file when $(DOMAIN).pot
# has changed. Possible values are "yes" and "no". Set this to no if
# the POT file is checked in the repository and the version control
# program ignores timestamps.
PO_DEPENDS_ON_POT = yes
# This tells whether or not to forcibly update $(DOMAIN).pot and
# regenerate PO files on "make dist". Possible values are "yes" and
# "no". Set this to no if the POT file and PO files are maintained
# externally.
DIST_DEPENDS_ON_UPDATE_PO = yes

54
po/POTFILES.in Normal file
View File

@ -0,0 +1,54 @@
# List of source files which contain translatable strings.
src/api-client.lisp
src/box.lisp
src/bs-tree.lisp
src/command-line.lisp
src/command-window.lisp
src/complete-window.lisp
src/complete.lisp
src/conditions.lisp
src/config.lisp
src/config.lisp.in
src/constants.lisp
src/conversations-window.lisp
src/date-formatter.lisp
src/db-utils.lisp
src/db.lisp
src/emoji-shortcodes.lisp
src/filesystem-utils.lisp
src/follow-requests.lisp
src/hooks.lisp
src/html-utils.lisp
src/interfaces.lisp
src/keybindings-window.lisp
src/keybindings.lisp
src/line-oriented-window.lisp
src/main-window.lisp
src/main.lisp
src/message-rendering-utils.lisp
src/message-window.lisp
src/misc-utils.lisp
src/modeline-window.lisp
src/modules.lisp
src/mtree-utils.lisp
src/notify-window.lisp
src/num-utils.lisp
src/os-utils.lisp
src/package.lisp
src/point-tracker.lisp
src/priority-queue.lisp
src/program-events.lisp
src/queue.lisp
src/rb-tree.lisp
src/resources-utils.lisp
src/sending-message.lisp
src/software-configuration.lisp
src/specials.lisp
src/stack.lisp
src/suggestions-window.lisp
src/tags-window.lisp
src/text-utils.lisp
src/thread-window.lisp
src/tui-utils.lisp
src/ui-goodies.lisp
src/windows.lisp

58
po/Rules-quot Normal file
View File

@ -0,0 +1,58 @@
# This file, Rules-quot, can be copied and used freely without restrictions.
# Special Makefile rules for English message catalogs with quotation marks.
DISTFILES.common.extra1 = quot.sed boldquot.sed en@quot.header en@boldquot.header insert-header.sin Rules-quot
.SUFFIXES: .insert-header .po-update-en
en@quot.po-create:
$(MAKE) en@quot.po-update
en@boldquot.po-create:
$(MAKE) en@boldquot.po-update
en@quot.po-update: en@quot.po-update-en
en@boldquot.po-update: en@boldquot.po-update-en
.insert-header.po-update-en:
@lang=`echo $@ | sed -e 's/\.po-update-en$$//'`; \
if test "$(PACKAGE)" = "gettext-tools" && test "$(CROSS_COMPILING)" != "yes"; then PATH=`pwd`/../src:$$PATH; GETTEXTLIBDIR=`cd $(top_srcdir)/src && pwd`; export GETTEXTLIBDIR; fi; \
tmpdir=`pwd`; \
echo "$$lang:"; \
ll=`echo $$lang | sed -e 's/@.*//'`; \
LC_ALL=C; export LC_ALL; \
cd $(srcdir); \
if $(MSGINIT) $(MSGINIT_OPTIONS) -i $(DOMAIN).pot --no-translator -l $$lang -o - 2>/dev/null \
| $(SED) -f $$tmpdir/$$lang.insert-header | $(MSGCONV) -t UTF-8 | \
{ case `$(MSGFILTER) --version | sed 1q | sed -e 's,^[^0-9]*,,'` in \
'' | 0.[0-9] | 0.[0-9].* | 0.1[0-8] | 0.1[0-8].*) \
$(MSGFILTER) $(SED) -f `echo $$lang | sed -e 's/.*@//'`.sed \
;; \
*) \
$(MSGFILTER) `echo $$lang | sed -e 's/.*@//'` \
;; \
esac } 2>/dev/null > $$tmpdir/$$lang.new.po \
; then \
if cmp $$lang.po $$tmpdir/$$lang.new.po >/dev/null 2>&1; then \
rm -f $$tmpdir/$$lang.new.po; \
else \
if mv -f $$tmpdir/$$lang.new.po $$lang.po; then \
:; \
else \
echo "creation of $$lang.po failed: cannot move $$tmpdir/$$lang.new.po to $$lang.po" 1>&2; \
exit 1; \
fi; \
fi; \
else \
echo "creation of $$lang.po failed!" 1>&2; \
rm -f $$tmpdir/$$lang.new.po; \
fi
en@quot.insert-header: insert-header.sin
sed -e '/^#/d' -e 's/HEADER/en@quot.header/g' $(srcdir)/insert-header.sin > en@quot.insert-header
en@boldquot.insert-header: insert-header.sin
sed -e '/^#/d' -e 's/HEADER/en@boldquot.header/g' $(srcdir)/insert-header.sin > en@boldquot.insert-header
mostlyclean: mostlyclean-quot
mostlyclean-quot:
rm -f *.insert-header

10
po/boldquot.sed Normal file
View File

@ -0,0 +1,10 @@
s/"\([^"]*\)"/“\1”/g
s/`\([^`']*\)'/‘\1’/g
s/ '\([^`']*\)' / ‘\1’ /g
s/ '\([^`']*\)'$/ ‘\1’/g
s/^'\([^`']*\)' /‘\1’ /g
s/“”/""/g
s/“/“/g
s/”/”/g
s/‘/‘/g
s/’/’/g

25
po/en@boldquot.header Normal file
View File

@ -0,0 +1,25 @@
# All this catalog "translates" are quotation characters.
# The msgids must be ASCII and therefore cannot contain real quotation
# characters, only substitutes like grave accent (0x60), apostrophe (0x27)
# and double quote (0x22). These substitutes look strange; see
# http://www.cl.cam.ac.uk/~mgk25/ucs/quotes.html
#
# This catalog translates grave accent (0x60) and apostrophe (0x27) to
# left single quotation mark (U+2018) and right single quotation mark (U+2019).
# It also translates pairs of apostrophe (0x27) to
# left single quotation mark (U+2018) and right single quotation mark (U+2019)
# and pairs of quotation mark (0x22) to
# left double quotation mark (U+201C) and right double quotation mark (U+201D).
#
# When output to an UTF-8 terminal, the quotation characters appear perfectly.
# When output to an ISO-8859-1 terminal, the single quotation marks are
# transliterated to apostrophes (by iconv in glibc 2.2 or newer) or to
# grave/acute accent (by libiconv), and the double quotation marks are
# transliterated to 0x22.
# When output to an ASCII terminal, the single quotation marks are
# transliterated to apostrophes, and the double quotation marks are
# transliterated to 0x22.
#
# This catalog furthermore displays the text between the quotation marks in
# bold face, assuming the VT100/XTerm escape sequences.
#

22
po/en@quot.header Normal file
View File

@ -0,0 +1,22 @@
# All this catalog "translates" are quotation characters.
# The msgids must be ASCII and therefore cannot contain real quotation
# characters, only substitutes like grave accent (0x60), apostrophe (0x27)
# and double quote (0x22). These substitutes look strange; see
# http://www.cl.cam.ac.uk/~mgk25/ucs/quotes.html
#
# This catalog translates grave accent (0x60) and apostrophe (0x27) to
# left single quotation mark (U+2018) and right single quotation mark (U+2019).
# It also translates pairs of apostrophe (0x27) to
# left single quotation mark (U+2018) and right single quotation mark (U+2019)
# and pairs of quotation mark (0x22) to
# left double quotation mark (U+201C) and right double quotation mark (U+201D).
#
# When output to an UTF-8 terminal, the quotation characters appear perfectly.
# When output to an ISO-8859-1 terminal, the single quotation marks are
# transliterated to apostrophes (by iconv in glibc 2.2 or newer) or to
# grave/acute accent (by libiconv), and the double quotation marks are
# transliterated to 0x22.
# When output to an ASCII terminal, the single quotation marks are
# transliterated to apostrophes, and the double quotation marks are
# transliterated to 0x22.
#

23
po/insert-header.sin Normal file
View File

@ -0,0 +1,23 @@
# Sed script that inserts the file called HEADER before the header entry.
#
# At each occurrence of a line starting with "msgid ", we execute the following
# commands. At the first occurrence, insert the file. At the following
# occurrences, do nothing. The distinction between the first and the following
# occurrences is achieved by looking at the hold space.
/^msgid /{
x
# Test if the hold space is empty.
s/m/m/
ta
# Yes it was empty. First occurrence. Read the file.
r HEADER
# Output the file's contents by reading the next line. But don't lose the
# current line while doing this.
g
N
bb
:a
# The hold space was nonempty. Following occurrences. Do nothing.
x
:b
}

801
po/it.po Normal file
View File

@ -0,0 +1,801 @@
# Italian translations for tinmop package
# Traduzioni italiane per il pacchetto tinmop..
# Copyright (C) 2020 cage
# This file is distributed under the same license as the tinmop package.
# cage <cage@invalid.org>, 2020.
#
msgid ""
msgstr ""
"Project-Id-Version: tinmop 0.0.1\n"
"Report-Msgid-Bugs-To: https://notabug.org/cage/tinmop/\n"
"POT-Creation-Date: 2020-05-08 15:15+0200\n"
"PO-Revision-Date: 2020-05-07 16:32+0200\n"
"Last-Translator: cage <cage@invalid.org>\n"
"Language-Team: Italian\n"
"Language: it\n"
"MIME-Version: 1.0\n"
"Content-Type: text/plain; charset=UTF-8\n"
"Content-Transfer-Encoding: 8bit\n"
"Plural-Forms: nplurals=2; plural=(n != 1);\n"
#: src/api-client.lisp:118
msgid "Please visit the address below."
msgstr "Per favore visita l'indirizzo mostrato piu' sotto."
#: src/api-client.lisp:176
#, lisp-format
msgid ""
"Credential invalid. Try to remove ~a and restart the software to "
"authenticate again."
msgstr ""
"Credenziali non più valide. Provare a rimuovere ~a e riavviare il programma "
"per riautenticarsi."
#: src/api-client.lisp:187
msgid "Save address"
msgstr "Salva l'indirizzo"
#: src/api-client.lisp:188
msgid "Open address"
msgstr "Apri l'indirizzo"
#: src/api-client.lisp:197
msgid "This client has been authorized"
msgstr "Questo client è stato autorizzato."
#: src/api-client.lisp:201
msgid "Got a generic error when registering client"
msgstr "Errore generico provando a registare il client"
#: src/api-client.lisp:203
#, lisp-format
msgid "File ~a saved"
msgstr "File ~a salvato"
#: src/api-client.lisp:205
msgid "Please enter below the file where to save the address"
msgstr "Inserisci piu' sotto il file dove salvare l'indirizzo"
#: src/api-client.lisp:225
msgid ""
"Error: was not able to create server socket to listen for authorization code"
msgstr ""
"Errore: non sono stato in grado di creare il socket per la cattura del "
"codice di autorizzazione."
#: src/api-client.lisp:631
#, lisp-format
msgid "Initializing empty credentials file in ~a"
msgstr "Inizializzo credenziali vuote (segnaposto) nel file ~a"
#: src/command-line.lisp:21
#, lisp-format
msgid "~a version ~a~%"
msgstr "~a versione ~a~%"
#: src/command-line.lisp:26
msgid "Print help and exit"
msgstr "Stampa un aiuto ed termina il programma"
#: src/command-line.lisp:30
msgid "Print program information and exit"
msgstr "Stampa informazioni sul programma e termina"
#: src/command-line.lisp:34
msgid "Starting folder"
msgstr "Cartella di partenza"
#: src/command-line.lisp:37
msgid "FOLDER-NAME"
msgstr "NOME-CARTELLA"
#: src/command-line.lisp:40
msgid "Starting timeline"
msgstr "Timeline di partenza"
#: src/command-line.lisp:42
msgid "TIMELINE-NAME"
msgstr "NOME-TIMELINE"
#: src/command-line.lisp:46
msgid "Update timeline"
msgstr "Aggiorna la timeline"
#: src/command-line.lisp:50
msgid "Check follows requests"
msgstr "Controlla le richieste di poterti seguire"
#: src/command-line.lisp:54
msgid "Execute script"
msgstr "Esegui script"
#: src/command-line.lisp:57
msgid "SCRIPT-FILE"
msgstr "SCRIPT-FILE"
#: src/command-window.lisp:298
#, lisp-format
msgid "Error: command ~a not found"
msgstr "Errore: comando ~a non trovato"
#: src/conditions.lisp:67 src/conditions.lisp:71 src/db.lisp:2113
#: src/message-rendering-utils.lisp:132 src/message-rendering-utils.lisp:166
#: src/message-rendering-utils.lisp:171
msgid "unknown"
msgstr "sconosciuto"
#: src/conversations-window.lisp:152
msgid "Conversations"
msgstr "Conversazioni"
#: src/db.lisp:149
msgid "federated"
msgstr "federata"
#: src/db.lisp:151
msgid "local"
msgstr "locale"
#: src/db.lisp:153
msgid "direct"
msgstr "diretta"
#: src/db.lisp:155
msgid "home"
msgstr "home"
#: src/follow-requests.lisp:68
msgid ""
"Please evaluate the following requests, only items shown below will be "
"accepted, deleted ones will be rejected:"
msgstr ""
"Per favore, prendi in considerazione le richieste qui sotto riportate. Se "
"cancelli un elemento la corrispondente richiesta sarà scartata altrimenti "
"verrà accettata."
#: src/html-utils.lisp:104
msgid "No address found"
msgstr "nessun indirizzo trovato"
#: src/keybindings.lisp:396
msgid "Enter"
msgstr "Invio"
#: src/keybindings.lisp:398
msgid "Delete"
msgstr "Canc"
#: src/keybindings.lisp:400
msgid "Page-up"
msgstr "Pagina-su"
#: src/keybindings.lisp:402
msgid "Page-down"
msgstr "Pagina-giù"
#: src/keybindings.lisp:458
msgid "No documentation available, you can help! :-)"
msgstr "Nessuna documentazione disponbile, aiutaci! :-)"
#: src/keybindings.lisp:490
msgid "Focused window keys"
msgstr "Tasti finestra attiva"
#: src/keybindings.lisp:491
msgid "Global keys"
msgstr "Mappa tasti globale"
#: src/keybindings.lisp:507
msgid "Quick help"
msgstr "Aiuto rapido"
#: src/line-oriented-window.lisp:269 src/ui-goodies.lisp:74
#: src/ui-goodies.lisp:88
msgid "Information"
msgstr "Informazione"
#: src/message-rendering-utils.lisp:69
msgid "This message will *not* be crypted"
msgstr "Questo messaggion *non* sarà cifrato"
#: src/message-rendering-utils.lisp:77
#, lisp-format
msgid "No key to crypt message for ~s found"
msgstr "Non è stata trovata una chiave per cifrare il messaggio destinato a ~s"
#: src/message-rendering-utils.lisp:114
#, lisp-format
msgid "Unable to find the crypto key for user ~s."
msgstr "Non trovo chiave crittografica per l'utente ~s"
#: src/message-rendering-utils.lisp:129
msgid "invalid type"
msgstr "tipo non valido"
#: src/message-rendering-utils.lisp:132
msgid "image"
msgstr "immagine"
#: src/message-rendering-utils.lisp:132
msgid "gifv"
msgstr "gifv"
#: src/message-rendering-utils.lisp:132
msgid "video"
msgstr "video"
#: src/message-rendering-utils.lisp:132
msgid "audio"
msgstr "audio"
#: src/message-rendering-utils.lisp:138
#, lisp-format
msgid "description: ~a~%"
msgstr "descrizione: ~a~%"
#: src/message-rendering-utils.lisp:141
#, lisp-format
msgid "size: ~aX~a pixels~%"
msgstr "dimensioni: ~aX~a pixels~%"
#: src/message-rendering-utils.lisp:148
#, lisp-format
msgid "duration: ~a~%"
msgstr "durata ~a~%"
#: src/message-rendering-utils.lisp:159 src/sending-message.lisp:132
msgid "Attachments"
msgstr "Allegati"
#: src/message-rendering-utils.lisp:168
#, lisp-format
msgid "type: ~a~%metadata~%~a~%address: ~a~2%"
msgstr "tipo: ~a~%metadati~%~a~%indirizzo: ~a~2%"
#: src/message-rendering-utils.lisp:210
msgid "From: "
msgstr "Scritto da: "
#: src/message-rendering-utils.lisp:211
msgid "Boosted: "
msgstr "Rilanciato per:"
#: src/message-rendering-utils.lisp:215
msgid "Date: "
msgstr "Scritto il: "
#: src/message-window.lisp:218
msgid "Messages"
msgstr "Messaggi"
#: src/modeline-window.lisp:29
msgid "modeline"
msgstr "modeline"
#: src/modules.lisp:33
#, lisp-format
msgid ""
"Unrecoverable error: file ~a not found in any of the directory ~a ~a ~a ~a"
msgstr ""
"Errore non rimediabile: file ~a non trovato in nessuna dellle seguenti "
"directory: ~a ~a ~a ~a"
#: src/notify-window.lisp:63
#, lisp-format
msgid "~a pending"
msgid_plural "~a pending"
msgstr[0] "~a in attesa"
msgstr[1] "Altre ~a in attesa"
#: src/os-utils.lisp:55
msgid ""
"No editor found, please configure the 'editor' directive in your "
"configuration file"
msgstr ""
"Nessun editor trovato, per favore configura la direttiva 'editor' nel tuo "
"file di configurazione."
#: src/program-events.lisp:41
#, lisp-format
msgid "Error: ~a"
msgstr "Errore: ~a"
#: src/program-events.lisp:413
msgid "No message selected!"
msgstr "Nessun messaggio selezionato!"
#: src/program-events.lisp:563
msgid "Message sent."
msgstr "Messaggio spedito"
#: src/program-events.lisp:618
#, lisp-format
msgid "Downloaded new messages for tag ~a"
msgstr "Scaricati nuovi messaggi per l'etichetta ~a."
#: src/resources-utils.lisp:55
#, lisp-format
msgid "Unrecoverable error: cannot find ~s in either ~s or ~s."
msgstr "Errore non rimediabile: non trovo ~s né in ~s né ~s."
#: src/sending-message.lisp:114
msgid "none"
msgstr "nessuno"
#: src/sending-message.lisp:115
msgid "Reply to: "
msgstr "Risposta per: "
#: src/sending-message.lisp:116
msgid "Subject:"
msgstr "Oggetto del messaggio: "
#: src/sending-message.lisp:117
msgid "Visibility:"
msgstr "Visibilità:"
#: src/software-configuration.lisp:415
msgid "This message was crypted."
msgstr "Questo messaggion era cifrato."
#: src/suggestions-window.lisp:33
#, lisp-format
msgid "Page ~a of ~a"
msgstr "Pagina ~a di ~a"
#: src/tags-window.lisp:140
msgid "Subscribed tags"
msgstr "Sottoscrizioni"
#: src/text-utils.lisp:456
#, lisp-format
msgid "Can not fit column of width of ~a in a box of width ~a"
msgstr ""
"Non posso adattare una colonna di larghezza ~a in una scatola di larghezza ~a"
#: src/text-utils.lisp:570
#, lisp-format
msgid "Unrecoverable error: ~a can not be fitted in a box of width ~a"
msgstr ""
"Errore non rimediabile: ~a non può adattarsi ad una scatola di larghezza ~a"
#: src/thread-window.lisp:134
msgid "no timeline selected"
msgstr "Nessuna timeline selezionata"
#: src/thread-window.lisp:142
msgid "no folder selected"
msgstr "Nessuna cartella selezionata"
#: src/thread-window.lisp:397
msgid "Missing subject"
msgstr "Oggetto mancante"
#: src/thread-window.lisp:729
#, lisp-format
msgid "No message with index ~a exists."
msgstr "Nessun messaggio esiste alla posizione ~a."
#: src/thread-window.lisp:838 src/thread-window.lisp:872
#, lisp-format
msgid "No next message that contains ~s exists."
msgstr "Nessun messaggio successivo che contenga ~s esiste."
#: src/thread-window.lisp:844 src/thread-window.lisp:878
#, lisp-format
msgid "No previous message that contains ~s exists."
msgstr "Nessun messaggio precedente che contenga ~s esiste."
#: src/thread-window.lisp:894
msgid "No others unread messages exist."
msgstr "Non ci sono altri messaggi non letti."
#: src/thread-window.lisp:905
msgid "Threads"
msgstr "Discussioni"
#: src/tui-utils.lisp:104
#, lisp-format
msgid "Unknown event ~a"
msgstr "Evento sconosciuto ~a"
#: src/ui-goodies.lisp:21
msgid "y"
msgstr "s"
#: src/ui-goodies.lisp:43
#, lisp-format
msgid "Delete ~a message? [y/N] "
msgid_plural "Delete ~a messages? [y/N] "
msgstr[0] "Cancella ~a messaggio? [s/N] "
msgstr[1] "Cancella ~a messaggi? [s/N] "
#: src/ui-goodies.lisp:58 src/ui-goodies.lisp:67
msgid "Task completed"
msgstr "Compito completato"
#: src/ui-goodies.lisp:81 src/ui-goodies.lisp:95
msgid "Error"
msgstr "Errore"
#: src/ui-goodies.lisp:117
#, lisp-format
msgid "File \"~a\" exists, overwrite?"
msgstr "Il file \"~a\" esiste. Lo sovrascrivo?"
#: src/ui-goodies.lisp:119 src/ui-goodies.lisp:124 src/windows.lisp:507
#: src/windows.lisp:563
msgid "Cancel"
msgstr "Annulla"
#: src/ui-goodies.lisp:129
#, lisp-format
msgid "Request failed: error code ~d message \"~a\""
msgstr "Richiesta fallita codice di errore: ~d, messaggio: ~a\""
#: src/ui-goodies.lisp:165
msgid "Jump to message: "
msgstr "Vai al messaggio: "
#: src/ui-goodies.lisp:182 src/ui-goodies.lisp:206 src/ui-goodies.lisp:306
msgid "Search key: "
msgstr "Criterio di ricerca: "
#: src/ui-goodies.lisp:263
msgid "Subscribe to: "
msgstr "Abbonati a: "
#: src/ui-goodies.lisp:279
msgid "Unsubscribe to: "
msgstr "Rimuovi la sottoscrizione a: "
#: src/ui-goodies.lisp:319
msgid "Focus changed"
msgstr "Il focus e' cambiato"
#: src/ui-goodies.lisp:329
msgid "Focus passed on threads window"
msgstr "Il focus è passato alla finestra delle discussioni."
#: src/ui-goodies.lisp:339
msgid "Focus passed on message window"
msgstr "Il focus è passato alla finestra del messaggio."
#: src/ui-goodies.lisp:350
msgid "Focus passed on send message window"
msgstr "Il focus è passato alla finestra di spedizione dei messaggi."
#: src/ui-goodies.lisp:361
msgid "Focus passed on follow requests window"
msgstr "Il focus è passato alla finestra delle richieste di seguirti."
#: src/ui-goodies.lisp:372
msgid "Focus passed on tags window"
msgstr "Il focus è passato alla finestra delle sottoscrizioni."
#: src/ui-goodies.lisp:382
msgid "Focus passed on conversation window"
msgstr "Il focus è passato alla finestra delle conversazioni."
#: src/ui-goodies.lisp:393
msgid "Focus passed on attach window"
msgstr "Il focus è passato alla finestra degli allegati."
#: src/ui-goodies.lisp:413
#, lisp-format
msgid "Saving messages in ~s"
msgstr "Salvo i messaggi in ~s"
#: src/ui-goodies.lisp:414
#, lisp-format
msgid "Saved message in ~s"
msgstr "Salvati i messaggi in ~s"
#: src/ui-goodies.lisp:417 src/ui-goodies.lisp:435
msgid "No folder specified."
msgstr "Nessuna cartella indicata."
#: src/ui-goodies.lisp:419
msgid "Move to folder: "
msgstr "Sposta nella cartella: "
#: src/ui-goodies.lisp:433
#, lisp-format
msgid "Folder ~s does not exists."
msgstr "La cartella ~s non esiste."
#: src/ui-goodies.lisp:437
msgid "Change folder: "
msgstr "Spostati nella cartella: "
#: src/ui-goodies.lisp:447
msgid "No timeline specified."
msgstr "Nessuna timeline indicata."
#: src/ui-goodies.lisp:450
msgid "Change timeline: "
msgstr "Spostati nella timeline: "
#: src/ui-goodies.lisp:480
msgid "Downloading messages."
msgstr "Scarico i messaggi."
#: src/ui-goodies.lisp:481 src/ui-goodies.lisp:502
msgid "Messages downloaded."
msgstr "Messaggi scaricati"
#: src/ui-goodies.lisp:501
msgid "Downloading tags messages."
msgstr "Scarico i messaggi dell'etichetta."
#: src/ui-goodies.lisp:514
msgid "Favorite this message?"
msgstr "Conservare tra i favoriti questo messaggio?"
#: src/ui-goodies.lisp:523
msgid "Favouring message."
msgstr "Conservo il messaggio tra i favoriti."
#: src/ui-goodies.lisp:524
msgid "Favoured message."
msgstr "Messaggio conservato tra i favoriti."
#: src/ui-goodies.lisp:529
msgid "Remove this message from your favourites?"
msgstr "Rimuovere dai preferiti questo messaggio?"
#: src/ui-goodies.lisp:538
msgid "Unfavouring message."
msgstr "Rimuovo messaggio dai favoriti."
#: src/ui-goodies.lisp:539
msgid "Unfavoured message."
msgstr "Rimuosso messaggio dai favoriti."
#: src/ui-goodies.lisp:544
msgid "Boost this message?"
msgstr "Rilancia questo messaggio?"
#: src/ui-goodies.lisp:553
msgid "Boosting message."
msgstr "Rilancio il messaggio."
#: src/ui-goodies.lisp:554
msgid "Boosted message."
msgstr "Messaggio rilanciato."
#: src/ui-goodies.lisp:559
msgid "Unboost this message?"
msgstr "Ritira il rilancio del messaggio?"
#: src/ui-goodies.lisp:568
msgid "Uboosting message."
msgstr "Ritiro il rilancio del messaggio."
#: src/ui-goodies.lisp:569
msgid "Unboosted message."
msgstr "Ritirato il rilancio del messaggio."
#: src/ui-goodies.lisp:577
#, lisp-format
msgid "Ignore ~s?"
msgstr "Ignorare ~s?"
#: src/ui-goodies.lisp:580
#, lisp-format
msgid "Ignoring ~s"
msgstr "Ignoro ~s"
#: src/ui-goodies.lisp:581
#, lisp-format
msgid "User ~s ignored"
msgstr "Utente ~s ignorato"
#: src/ui-goodies.lisp:591
msgid "No username specified."
msgstr "Nessun nome utente indicato."
#: src/ui-goodies.lisp:593
msgid "Unignore username: "
msgstr "Riprendere a leggere i messaggi di:"
#: src/ui-goodies.lisp:621
#, lisp-format
msgid "File ~s does not exists."
msgstr "Il file ~s non esiste."
#: src/ui-goodies.lisp:624
msgid "Add attachment: "
msgstr "Aggiungi allegato: "
#: src/ui-goodies.lisp:634
msgid "New subject: "
msgstr "Nuovo oggetto del messaggio: "
#: src/ui-goodies.lisp:643
msgid "New visibility: "
msgstr "Nuovo livello di visibilità:"
#: src/ui-goodies.lisp:690
#, lisp-format
msgid "Your message is ~a character too long."
msgid_plural "Your message is ~a characters too long."
msgstr[0] "Il tuo messaggio e più lungo del limite ammesso di ~a carattere."
msgstr[1] "Il tuo messaggio e più lungo del limite ammesso di ~a caratteri."
#: src/ui-goodies.lisp:714
msgid "Add subject: "
msgstr "Oggetto del messaggio: "
#: src/ui-goodies.lisp:771
#, lisp-format
msgid "The maximum allowed number of media is ~a."
msgstr "Il numero massimo di file da allegare è ~a."
#: src/ui-goodies.lisp:774
msgid "Sending message"
msgstr "Spedisco il messaggio"
#: src/ui-goodies.lisp:823
msgid "Follow: "
msgstr "Segui: "
#: src/ui-goodies.lisp:826
#, lisp-format
msgid "Following ~a"
msgstr "Segui ~a"
#: src/ui-goodies.lisp:827
#, lisp-format
msgid "Followed ~a"
msgstr "Adesso segui ~a "
#: src/ui-goodies.lisp:831
msgid "Unfollow: "
msgstr "Abbandona: "
#: src/ui-goodies.lisp:834
#, lisp-format
msgid "Unfollowing ~a"
msgstr "Abbandona ~a"
#: src/ui-goodies.lisp:835
#, lisp-format
msgid "Unfollowed ~a"
msgstr "Hai abbandonato ~a"
#: src/ui-goodies.lisp:864
msgid "Confirm operation?"
msgstr "Confermi l'operazione?"
#: src/ui-goodies.lisp:902
msgid "Updating conversations."
msgstr "Aggiorno le conversazioni"
#: src/ui-goodies.lisp:903
msgid "Conversations updated."
msgstr "Conversazioni aggiornate"
#: src/ui-goodies.lisp:913
msgid "Open conversation: "
msgstr "Apri una conversazione: "
#: src/ui-goodies.lisp:948
msgid "Old name: "
msgstr "Nome precedente: "
#: src/ui-goodies.lisp:960
#, lisp-format
msgid "A conversation with name ~a already exists."
msgstr "Una conversazione con nome ~a esiste già."
#: src/ui-goodies.lisp:964
msgid "New name: "
msgstr "Nuovo nome: "
#: src/ui-goodies.lisp:980
#, lisp-format
msgid "Ignore conversation ~s? [y/N] "
msgstr "Ignorare la conversazione ~s? [s/N] "
#: src/ui-goodies.lisp:996
#, lisp-format
msgid "Delete conversation ~s? [y/N] "
msgstr "Ignorare la conversazione ~s? [s/N] "
#: src/ui-goodies.lisp:1015
#, lisp-format
msgid "Comment too long by ~a character"
msgid_plural "Comment too long by ~a characters"
msgstr[0] "Il commento è troppo lungo di ~a caratteri"
msgstr[1] "Il commento è troppo lungo di ~a caratteri"
#: src/ui-goodies.lisp:1022
#, lisp-format
msgid "Reporting user: ~s"
msgstr "Segnalo l'utente ~s"
#: src/ui-goodies.lisp:1023
msgid "Report trasmitted."
msgstr "Segnalazione trasmessa."
#: src/ui-goodies.lisp:1026
msgid "Comment on reports: "
msgstr "Commento sulla segnalazione: "
#: src/ui-goodies.lisp:1042 src/ui-goodies.lisp:1075 src/ui-goodies.lisp:1093
#, lisp-format
msgid "User ~s does not exists in database"
msgstr "L'utente ~s non esiste nel database"
#: src/ui-goodies.lisp:1045 src/ui-goodies.lisp:1078 src/ui-goodies.lisp:1096
msgid "Username: "
msgstr "Nome utente: "
#: src/ui-goodies.lisp:1055
#, lisp-format
msgid "Added crypto key for user ~s"
msgstr "Aggiunta chiave crittografica per l'utente ~s"
#: src/ui-goodies.lisp:1058
msgid "Key: "
msgstr "Chiave: "
#: src/ui-goodies.lisp:1072
#, lisp-format
msgid "Generated key for user ~s"
msgstr "Generata chiave crittografica per l'utente ~s"
#: src/ui-goodies.lisp:1073
#, lisp-format
msgid "user ~s key ~s"
msgstr "utente ~s chiave ~s"
#: src/ui-goodies.lisp:1089
#, lisp-format
msgid "Added key for user ~s: ~a"
msgstr "Aggiunta chiave crittografica per l'utente ~s: ~a"
#: src/windows.lisp:513 src/windows.lisp:569
msgid "OK"
msgstr "OK"
#~ msgid "The list is too big to be displayed entirely"
#~ msgstr "La lista è troppo lunga per essere mostrata interamente"
#~ msgid ""
#~ "Please visit the address below and then paste here the autorization code "
#~ "you got from that website."
#~ msgstr ""
#~ "Per favore, visita l'indirizzo indicato più sotto e poi inserisci qui il "
#~ "codice di autorizzazione che il sito ti ha fornito."
#~ msgid "Authorization code:"
#~ msgstr "Codice di autorizzazione:"
#~ msgid "timeline unknown"
#~ msgstr "timeline sconosciuta"
#~ msgid "Timeline ~s does not exists in folder ~s."
#~ msgstr "La timeline ~s non esiste nella cartella ~s."
#~ msgid "Confirm accepting and rejecting the following requests?"
#~ msgstr "Confermi l'operazione?"
#~ msgid "Fetching messages."
#~ msgstr "Recupero i messaggi."
#~ msgid "~%---- attachments ----~%"
#~ msgstr "~%---- allegati ----~%"
#~ msgid "No message"
#~ msgstr "Nessun messaggio"
#~ msgid "Save link"
#~ msgstr "Salva link"
#~ msgid "Open link"
#~ msgstr "Apri il link"
#~ msgid "Unable to complete ~a"
#~ msgstr "Non posso completare ~a"

6
po/quot.sed Normal file
View File

@ -0,0 +1,6 @@
s/"\([^"]*\)"/“\1”/g
s/`\([^`']*\)'/‘\1’/g
s/ '\([^`']*\)' / ‘\1’ /g
s/ '\([^`']*\)'$/ ‘\1’/g
s/^'\([^`']*\)' /‘\1’ /g
s/“”/""/g

19
po/remove-potcdate.sin Normal file
View File

@ -0,0 +1,19 @@
# Sed script that remove the POT-Creation-Date line in the header entry
# from a POT file.
#
# The distinction between the first and the following occurrences of the
# pattern is achieved by looking at the hold space.
/^"POT-Creation-Date: .*"$/{
x
# Test if the hold space is empty.
s/P/P/
ta
# Yes it was empty. First occurrence. Remove the line.
g
d
bb
:a
# The hold space was nonempty. Following occurrences. Do nothing.
x
:b
}

748
po/tinmop.pot Normal file
View File

@ -0,0 +1,748 @@
# SOME DESCRIPTIVE TITLE.
# Copyright (C) YEAR cage
# This file is distributed under the same license as the tinmop package.
# FIRST AUTHOR <EMAIL@ADDRESS>, YEAR.
#
#, fuzzy
msgid ""
msgstr ""
"Project-Id-Version: tinmop 0.0.1\n"
"Report-Msgid-Bugs-To: https://notabug.org/cage/tinmop/\n"
"POT-Creation-Date: 2020-05-08 15:15+0200\n"
"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"
"Last-Translator: FULL NAME <EMAIL@ADDRESS>\n"
"Language-Team: LANGUAGE <LL@li.org>\n"
"Language: \n"
"MIME-Version: 1.0\n"
"Content-Type: text/plain; charset=CHARSET\n"
"Content-Transfer-Encoding: 8bit\n"
"Plural-Forms: nplurals=INTEGER; plural=EXPRESSION;\n"
#: src/api-client.lisp:118
msgid "Please visit the address below."
msgstr ""
#: src/api-client.lisp:176
#, lisp-format
msgid ""
"Credential invalid. Try to remove ~a and restart the software to "
"authenticate again."
msgstr ""
#: src/api-client.lisp:187
msgid "Save address"
msgstr ""
#: src/api-client.lisp:188
msgid "Open address"
msgstr ""
#: src/api-client.lisp:197
msgid "This client has been authorized"
msgstr ""
#: src/api-client.lisp:201
msgid "Got a generic error when registering client"
msgstr ""
#: src/api-client.lisp:203
#, lisp-format
msgid "File ~a saved"
msgstr ""
#: src/api-client.lisp:205
msgid "Please enter below the file where to save the address"
msgstr ""
#: src/api-client.lisp:225
msgid ""
"Error: was not able to create server socket to listen for authorization code"
msgstr ""
#: src/api-client.lisp:631
#, lisp-format
msgid "Initializing empty credentials file in ~a"
msgstr ""
#: src/command-line.lisp:21
#, lisp-format
msgid "~a version ~a~%"
msgstr ""
#: src/command-line.lisp:26
msgid "Print help and exit"
msgstr ""
#: src/command-line.lisp:30
msgid "Print program information and exit"
msgstr ""
#: src/command-line.lisp:34
msgid "Starting folder"
msgstr ""
#: src/command-line.lisp:37
msgid "FOLDER-NAME"
msgstr ""
#: src/command-line.lisp:40
msgid "Starting timeline"
msgstr ""
#: src/command-line.lisp:42
msgid "TIMELINE-NAME"
msgstr ""
#: src/command-line.lisp:46
msgid "Update timeline"
msgstr ""
#: src/command-line.lisp:50
msgid "Check follows requests"
msgstr ""
#: src/command-line.lisp:54
msgid "Execute script"
msgstr ""
#: src/command-line.lisp:57
msgid "SCRIPT-FILE"
msgstr ""
#: src/command-window.lisp:298
#, lisp-format
msgid "Error: command ~a not found"
msgstr ""
#: src/conditions.lisp:67 src/conditions.lisp:71 src/db.lisp:2113
#: src/message-rendering-utils.lisp:132 src/message-rendering-utils.lisp:166
#: src/message-rendering-utils.lisp:171
msgid "unknown"
msgstr ""
#: src/conversations-window.lisp:152
msgid "Conversations"
msgstr ""
#: src/db.lisp:149
msgid "federated"
msgstr ""
#: src/db.lisp:151
msgid "local"
msgstr ""
#: src/db.lisp:153
msgid "direct"
msgstr ""
#: src/db.lisp:155
msgid "home"
msgstr ""
#: src/follow-requests.lisp:68
msgid ""
"Please evaluate the following requests, only items shown below will be "
"accepted, deleted ones will be rejected:"
msgstr ""
#: src/html-utils.lisp:104
msgid "No address found"
msgstr ""
#: src/keybindings.lisp:396
msgid "Enter"
msgstr ""
#: src/keybindings.lisp:398
msgid "Delete"
msgstr ""
#: src/keybindings.lisp:400
msgid "Page-up"
msgstr ""
#: src/keybindings.lisp:402
msgid "Page-down"
msgstr ""
#: src/keybindings.lisp:458
msgid "No documentation available, you can help! :-)"
msgstr ""
#: src/keybindings.lisp:490
msgid "Focused window keys"
msgstr ""
#: src/keybindings.lisp:491
msgid "Global keys"
msgstr ""
#: src/keybindings.lisp:507
msgid "Quick help"
msgstr ""
#: src/line-oriented-window.lisp:269 src/ui-goodies.lisp:74
#: src/ui-goodies.lisp:88
msgid "Information"
msgstr ""
#: src/message-rendering-utils.lisp:69
msgid "This message will *not* be crypted"
msgstr ""
#: src/message-rendering-utils.lisp:77
#, lisp-format
msgid "No key to crypt message for ~s found"
msgstr ""
#: src/message-rendering-utils.lisp:114
#, lisp-format
msgid "Unable to find the crypto key for user ~s."
msgstr ""
#: src/message-rendering-utils.lisp:129
msgid "invalid type"
msgstr ""
#: src/message-rendering-utils.lisp:132
msgid "image"
msgstr ""
#: src/message-rendering-utils.lisp:132
msgid "gifv"
msgstr ""
#: src/message-rendering-utils.lisp:132
msgid "video"
msgstr ""
#: src/message-rendering-utils.lisp:132
msgid "audio"
msgstr ""
#: src/message-rendering-utils.lisp:138
#, lisp-format
msgid "description: ~a~%"
msgstr ""
#: src/message-rendering-utils.lisp:141
#, lisp-format
msgid "size: ~aX~a pixels~%"
msgstr ""
#: src/message-rendering-utils.lisp:148
#, lisp-format
msgid "duration: ~a~%"
msgstr ""
#: src/message-rendering-utils.lisp:159 src/sending-message.lisp:132
msgid "Attachments"
msgstr ""
#: src/message-rendering-utils.lisp:168
#, lisp-format
msgid "type: ~a~%metadata~%~a~%address: ~a~2%"
msgstr ""
#: src/message-rendering-utils.lisp:210
msgid "From: "
msgstr ""
#: src/message-rendering-utils.lisp:211
msgid "Boosted: "
msgstr ""
#: src/message-rendering-utils.lisp:215
msgid "Date: "
msgstr ""
#: src/message-window.lisp:218
msgid "Messages"
msgstr ""
#: src/modeline-window.lisp:29
msgid "modeline"
msgstr ""
#: src/modules.lisp:33
#, lisp-format
msgid ""
"Unrecoverable error: file ~a not found in any of the directory ~a ~a ~a ~a"
msgstr ""
#: src/notify-window.lisp:63
#, lisp-format
msgid "~a pending"
msgid_plural "~a pending"
msgstr[0] ""
msgstr[1] ""
#: src/os-utils.lisp:55
msgid ""
"No editor found, please configure the 'editor' directive in your "
"configuration file"
msgstr ""
#: src/program-events.lisp:41
#, lisp-format
msgid "Error: ~a"
msgstr ""
#: src/program-events.lisp:413
msgid "No message selected!"
msgstr ""
#: src/program-events.lisp:563
msgid "Message sent."
msgstr ""
#: src/program-events.lisp:618
#, lisp-format
msgid "Downloaded new messages for tag ~a"
msgstr ""
#: src/resources-utils.lisp:55
#, lisp-format
msgid "Unrecoverable error: cannot find ~s in either ~s or ~s."
msgstr ""
#: src/sending-message.lisp:114
msgid "none"
msgstr ""
#: src/sending-message.lisp:115
msgid "Reply to: "
msgstr ""
#: src/sending-message.lisp:116
msgid "Subject:"
msgstr ""
#: src/sending-message.lisp:117
msgid "Visibility:"
msgstr ""
#: src/software-configuration.lisp:415
msgid "This message was crypted."
msgstr ""
#: src/suggestions-window.lisp:33
#, lisp-format
msgid "Page ~a of ~a"
msgstr ""
#: src/tags-window.lisp:140
msgid "Subscribed tags"
msgstr ""
#: src/text-utils.lisp:456
#, lisp-format
msgid "Can not fit column of width of ~a in a box of width ~a"
msgstr ""
#: src/text-utils.lisp:570
#, lisp-format
msgid "Unrecoverable error: ~a can not be fitted in a box of width ~a"
msgstr ""
#: src/thread-window.lisp:134
msgid "no timeline selected"
msgstr ""
#: src/thread-window.lisp:142
msgid "no folder selected"
msgstr ""
#: src/thread-window.lisp:397
msgid "Missing subject"
msgstr ""
#: src/thread-window.lisp:729
#, lisp-format
msgid "No message with index ~a exists."
msgstr ""
#: src/thread-window.lisp:838 src/thread-window.lisp:872
#, lisp-format
msgid "No next message that contains ~s exists."
msgstr ""
#: src/thread-window.lisp:844 src/thread-window.lisp:878
#, lisp-format
msgid "No previous message that contains ~s exists."
msgstr ""
#: src/thread-window.lisp:894
msgid "No others unread messages exist."
msgstr ""
#: src/thread-window.lisp:905
msgid "Threads"
msgstr ""
#: src/tui-utils.lisp:104
#, lisp-format
msgid "Unknown event ~a"
msgstr ""
#: src/ui-goodies.lisp:21
msgid "y"
msgstr ""
#: src/ui-goodies.lisp:43
#, lisp-format
msgid "Delete ~a message? [y/N] "
msgid_plural "Delete ~a messages? [y/N] "
msgstr[0] ""
msgstr[1] ""
#: src/ui-goodies.lisp:58 src/ui-goodies.lisp:67
msgid "Task completed"
msgstr ""
#: src/ui-goodies.lisp:81 src/ui-goodies.lisp:95
msgid "Error"
msgstr ""
#: src/ui-goodies.lisp:117
#, lisp-format
msgid "File \"~a\" exists, overwrite?"
msgstr ""
#: src/ui-goodies.lisp:119 src/ui-goodies.lisp:124 src/windows.lisp:507
#: src/windows.lisp:563
msgid "Cancel"
msgstr ""
#: src/ui-goodies.lisp:129
#, lisp-format
msgid "Request failed: error code ~d message \"~a\""
msgstr ""
#: src/ui-goodies.lisp:165
msgid "Jump to message: "
msgstr ""
#: src/ui-goodies.lisp:182 src/ui-goodies.lisp:206 src/ui-goodies.lisp:306
msgid "Search key: "
msgstr ""
#: src/ui-goodies.lisp:263
msgid "Subscribe to: "
msgstr ""
#: src/ui-goodies.lisp:279
msgid "Unsubscribe to: "
msgstr ""
#: src/ui-goodies.lisp:319
msgid "Focus changed"
msgstr ""
#: src/ui-goodies.lisp:329
msgid "Focus passed on threads window"
msgstr ""
#: src/ui-goodies.lisp:339
msgid "Focus passed on message window"
msgstr ""
#: src/ui-goodies.lisp:350
msgid "Focus passed on send message window"
msgstr ""
#: src/ui-goodies.lisp:361
msgid "Focus passed on follow requests window"
msgstr ""
#: src/ui-goodies.lisp:372
msgid "Focus passed on tags window"
msgstr ""
#: src/ui-goodies.lisp:382
msgid "Focus passed on conversation window"
msgstr ""
#: src/ui-goodies.lisp:393
msgid "Focus passed on attach window"
msgstr ""
#: src/ui-goodies.lisp:413
#, lisp-format
msgid "Saving messages in ~s"
msgstr ""
#: src/ui-goodies.lisp:414
#, lisp-format
msgid "Saved message in ~s"
msgstr ""
#: src/ui-goodies.lisp:417 src/ui-goodies.lisp:435
msgid "No folder specified."
msgstr ""
#: src/ui-goodies.lisp:419
msgid "Move to folder: "
msgstr ""
#: src/ui-goodies.lisp:433
#, lisp-format
msgid "Folder ~s does not exists."
msgstr ""
#: src/ui-goodies.lisp:437
msgid "Change folder: "
msgstr ""
#: src/ui-goodies.lisp:447
msgid "No timeline specified."
msgstr ""
#: src/ui-goodies.lisp:450
msgid "Change timeline: "
msgstr ""
#: src/ui-goodies.lisp:480
msgid "Downloading messages."
msgstr ""
#: src/ui-goodies.lisp:481 src/ui-goodies.lisp:502
msgid "Messages downloaded."
msgstr ""
#: src/ui-goodies.lisp:501
msgid "Downloading tags messages."
msgstr ""
#: src/ui-goodies.lisp:514
msgid "Favorite this message?"
msgstr ""
#: src/ui-goodies.lisp:523
msgid "Favouring message."
msgstr ""
#: src/ui-goodies.lisp:524
msgid "Favoured message."
msgstr ""
#: src/ui-goodies.lisp:529
msgid "Remove this message from your favourites?"
msgstr ""
#: src/ui-goodies.lisp:538
msgid "Unfavouring message."
msgstr ""
#: src/ui-goodies.lisp:539
msgid "Unfavoured message."
msgstr ""
#: src/ui-goodies.lisp:544
msgid "Boost this message?"
msgstr ""
#: src/ui-goodies.lisp:553
msgid "Boosting message."
msgstr ""
#: src/ui-goodies.lisp:554
msgid "Boosted message."
msgstr ""
#: src/ui-goodies.lisp:559
msgid "Unboost this message?"
msgstr ""
#: src/ui-goodies.lisp:568
msgid "Uboosting message."
msgstr ""
#: src/ui-goodies.lisp:569
msgid "Unboosted message."
msgstr ""
#: src/ui-goodies.lisp:577
#, lisp-format
msgid "Ignore ~s?"
msgstr ""
#: src/ui-goodies.lisp:580
#, lisp-format
msgid "Ignoring ~s"
msgstr ""
#: src/ui-goodies.lisp:581
#, lisp-format
msgid "User ~s ignored"
msgstr ""
#: src/ui-goodies.lisp:591
msgid "No username specified."
msgstr ""
#: src/ui-goodies.lisp:593
msgid "Unignore username: "
msgstr ""
#: src/ui-goodies.lisp:621
#, lisp-format
msgid "File ~s does not exists."
msgstr ""
#: src/ui-goodies.lisp:624
msgid "Add attachment: "
msgstr ""
#: src/ui-goodies.lisp:634
msgid "New subject: "
msgstr ""
#: src/ui-goodies.lisp:643
msgid "New visibility: "
msgstr ""
#: src/ui-goodies.lisp:690
#, lisp-format
msgid "Your message is ~a character too long."
msgid_plural "Your message is ~a characters too long."
msgstr[0] ""
msgstr[1] ""
#: src/ui-goodies.lisp:714
msgid "Add subject: "
msgstr ""
#: src/ui-goodies.lisp:771
#, lisp-format
msgid "The maximum allowed number of media is ~a."
msgstr ""
#: src/ui-goodies.lisp:774
msgid "Sending message"
msgstr ""
#: src/ui-goodies.lisp:823
msgid "Follow: "
msgstr ""
#: src/ui-goodies.lisp:826
#, lisp-format
msgid "Following ~a"
msgstr ""
#: src/ui-goodies.lisp:827
#, lisp-format
msgid "Followed ~a"
msgstr ""
#: src/ui-goodies.lisp:831
msgid "Unfollow: "
msgstr ""
#: src/ui-goodies.lisp:834
#, lisp-format
msgid "Unfollowing ~a"
msgstr ""
#: src/ui-goodies.lisp:835
#, lisp-format
msgid "Unfollowed ~a"
msgstr ""
#: src/ui-goodies.lisp:864
msgid "Confirm operation?"
msgstr ""
#: src/ui-goodies.lisp:902
msgid "Updating conversations."
msgstr ""
#: src/ui-goodies.lisp:903
msgid "Conversations updated."
msgstr ""
#: src/ui-goodies.lisp:913
msgid "Open conversation: "
msgstr ""
#: src/ui-goodies.lisp:948
msgid "Old name: "
msgstr ""
#: src/ui-goodies.lisp:960
#, lisp-format
msgid "A conversation with name ~a already exists."
msgstr ""
#: src/ui-goodies.lisp:964
msgid "New name: "
msgstr ""
#: src/ui-goodies.lisp:980
#, lisp-format
msgid "Ignore conversation ~s? [y/N] "
msgstr ""
#: src/ui-goodies.lisp:996
#, lisp-format
msgid "Delete conversation ~s? [y/N] "
msgstr ""
#: src/ui-goodies.lisp:1015
#, lisp-format
msgid "Comment too long by ~a character"
msgid_plural "Comment too long by ~a characters"
msgstr[0] ""
msgstr[1] ""
#: src/ui-goodies.lisp:1022
#, lisp-format
msgid "Reporting user: ~s"
msgstr ""
#: src/ui-goodies.lisp:1023
msgid "Report trasmitted."
msgstr ""
#: src/ui-goodies.lisp:1026
msgid "Comment on reports: "
msgstr ""
#: src/ui-goodies.lisp:1042 src/ui-goodies.lisp:1075 src/ui-goodies.lisp:1093
#, lisp-format
msgid "User ~s does not exists in database"
msgstr ""
#: src/ui-goodies.lisp:1045 src/ui-goodies.lisp:1078 src/ui-goodies.lisp:1096
msgid "Username: "
msgstr ""
#: src/ui-goodies.lisp:1055
#, lisp-format
msgid "Added crypto key for user ~s"
msgstr ""
#: src/ui-goodies.lisp:1058
msgid "Key: "
msgstr ""
#: src/ui-goodies.lisp:1072
#, lisp-format
msgid "Generated key for user ~s"
msgstr ""
#: src/ui-goodies.lisp:1073
#, lisp-format
msgid "user ~s key ~s"
msgstr ""
#: src/ui-goodies.lisp:1089
#, lisp-format
msgid "Added key for user ~s: ~a"
msgstr ""
#: src/windows.lisp:513 src/windows.lisp:569
msgid "OK"
msgstr ""

135
quick_quicklisp.sh.in Normal file
View File

@ -0,0 +1,135 @@
#! @BASH@
# tinmop: an humble mastodon client
# Copyright (C) 2020 cage
# 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/][http://www.gnu.org/licenses/]].
QUICKLISP_INSTALL_DIR=$HOME/quicklisp/
QUICKLISP_URL="https://beta.quicklisp.org/quicklisp.lisp"
QUICKLISP_SIG_URL="https://beta.quicklisp.org/quicklisp.lisp.asc"
QUICKLISP_KEY_URL="https://beta.quicklisp.org/release-key.txt"
QUICKLISP="quicklisp.lisp"
QUICKLISP_SIG="quicklisp.lisp.asc"
QUICKLISP_KEY="release-key"
QUICKLISP_SIGNATURE="D7A3 +489D +DEFE +32B7 +D0E7 +CC61 +3079 +65AB +028B +5FF7";
LISP_SOURCE_REGISTRY_DIR="$HOME/.config/common-lisp/"
LISP_SOURCE_REGISTRY_FILE="$LISP_SOURCE_REGISTRY_DIR/source-registry.conf"
BOLD_TEXT="\033[1m"
NORMAL_TEXT="\033[0m"
VERIFY_OK_RES=2
echo_bold () {
echo -e "${BOLD_TEXT}${1}${NORMAL_TEXT}";
}
check_quicklisp () {
if [ -d "$QUICKLISP_INSTALL_DIR" ]; then
echo 0;
else
echo 1;
fi
}
check_quicklisp_signature () {
chk1_prog='BEGIN {res=0} /Good signature.*release@quicklisp.org/ {res++; print res}'
chk2_prog="BEGIN {res=0} /${QUICKLISP_SIGNATURE}/ {res++; print res}"
res1=$(LC_MESSAGES="C" @GPG@ --verify quicklisp.lisp.asc quicklisp.lisp 2> >(@GAWK@ -- "${chk1_prog}"))
res2=$(@GPG@ --verify quicklisp.lisp.asc quicklisp.lisp 2> >(@GAWK@ -- "${chk2_prog}"))
res=$(expr $res1 + $res2)
echo -n "$res"
}
install_quicklisp () {
echo_bold "Downloading quicklisp...";
@CURL@ "$QUICKLISP_URL" > $QUICKLISP;
@CURL@ "$QUICKLISP_SIG_URL" > $QUICKLISP_SIG;
@CURL@ "$QUICKLISP_KEY_URL" > $QUICKLISP_KEY;
echo_bold "Importing gpg key.";
@GPG@ --import $QUICKLISP_KEY;
echo_bold "Verifing key";
signature_verified=$(check_quicklisp_signature);
if [ "$signature_verified" -ne $VERIFY_OK_RES ]; then
echo_bold "Key verification failed!"
exit 1;
else
echo_bold "Key sucessfully verified.";
@LISP_COMPILER@ --load $QUICKLISP \
--eval "(quicklisp-quickstart:install)" \
--eval "(ql:add-to-init-file)" \
--eval "(sb-ext:quit)";
@MKDIR_P@ -p $LISP_SOURCE_REGISTRY_DIR;
PAR_PWD="${PWD%/*}";
echo "(:source-registry" > $LISP_SOURCE_REGISTRY_FILE;
echo " (:tree \"$PAR_PWD\")" >> $LISP_SOURCE_REGISTRY_FILE;
echo ":inherit-configuration)" >> $LISP_SOURCE_REGISTRY_FILE;
echo "quicklisp installed";
fi
}
install_dependency () {
# add here the lisp dependency
# e.g.
# @LISP_COMPILER@ \ <- note the '\'
# --eval "(ql:quickload \"swank\")" \ <- note the '\'
# --eval "(sb-ext:quit)"; <- keep this line as latest
@LISP_COMPILER@ \
--eval "(ql:quickload \"alexandria\")" \
--eval "(ql:quickload \"cl-ppcre\")" \
--eval "(ql:quickload \"tooter\")" \
--eval "(ql:quickload \"croatoan\")" \
--eval "(ql:quickload \"osicat\")" \
--eval "(ql:quickload \"cl-spark\")" \
--eval "(ql:quickload \"access\")" \
--eval "(ql:quickload \"sqlite\")" \
--eval "(ql:quickload \"sxql\")" \
--eval "(ql:quickload \"sxql-composer\")" \
--eval "(ql:quickload \"marshal\")" \
--eval "(ql:quickload \"bordeaux-threads\")" \
--eval "(ql:quickload \"log4cl\")" \
--eval "(ql:quickload \"local-time\")" \
--eval "(ql:quickload \"cl-colors2\")" \
--eval "(ql:quickload \"cl-i18n\")" \
--eval "(ql:quickload \"clunit2\")" \
--eval "(ql:quickload \"esrap\")" \
--eval "(ql:quickload \"ieee-floats\")" \
--eval "(ql:quickload \"parse-number\")" \
--eval "(ql:quickload \"cl-html5-parser\")" \
--eval "(ql:quickload \"unix-opts\")" \
--eval "(ql:quickload \"crypto-shortcuts\")" \
--eval "(ql:quickload \"drakma\")" \
--eval "(ql:quickload \"usocket\")" \
--eval "(sb-ext:quit)";
}
quicklisp_installed_p=$(check_quicklisp);
if [ $quicklisp_installed_p -eq 0 ]; then
echo_bold "Quicklisp already installed; fetching libraries...";
install_dependency;
else
install_quicklisp;
install_dependency;
fi
echo_bold "Finished."

636
src/api-client.lisp Normal file
View File

@ -0,0 +1,636 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :api-client)
(defparameter *client* nil
"The tooter client, used to access mastodon")
(defparameter *credentials* nil
"An istance of 'credentials' used to holds the intormation needed to
access a mastodon instance")
(defparameter *client-lock* (bt:make-recursive-lock)
"The Lock for prevent race conditions when accessing the mastodon server")
(define-constant +credentials-filename+ "client" :test #'string=
:documentation "The name of the file where
credentials are stored")
(define-constant +protocol-scheme+ "https://" :test #'string=
:documentation "The scheme of the protocol that the
mastodon server understand.")
(defun make-base-slot ()
"Makes the 'base' slots for credential, used in credentials
initform."
(strcat +protocol-scheme+ (swconf:config-server-name)))
(defclass credentials ()
((base
:initform (make-base-slot)
:initarg :base
:accessor base
:documentation "The url of the mastodon instance to be accessed")
(key
:initform nil
:initarg :key
:accessor key
:documentation "API key to access the instance")
(secret
:initform nil
:initarg :secret
:accessor secret
:documentation "Secret key to access the instance")
(access-token
:initform nil
:initarg :access-token
:accessor access-token
:documentation "Access token to access the instance"))
(:documentation "Represents the credentials to access a mastodon
instance"))
(defmethod marshal:class-persistant-slots ((object credentials))
"Serializer for class `credentials', see `cl-marshal'"
(append '(base key secret access-token)
(call-next-method)))
(defun dump-credentials ()
"Serialize `*credential*' to disk"
(let ((resource-file (res:get-data-file +credentials-filename+)))
(fs:dump-sequence-to-file (serialize *credentials*)
resource-file)))
(defun forget-credentials ()
"Remove credentials data file"
(conditions:with-default-on-error (nil)
(let ((resource-file (res:get-data-file +credentials-filename+)))
(fs:delete-file-if-exists resource-file))))
(defun credentials-complete-p ()
"Returns non nil if *credentials* contains all necessary data to log
into the mastodon server"
(when *credentials*
(with-accessors ((base base)
(key key)
(secret secret)
(access-token access-token)) *credentials*
(and base
key
secret
access-token))))
(defclass api-client (tooter:client) ()
(:documentation "A mastodon client instance"))
(defun copy-credentials-to-client ()
"Copy credential data from `*credentials*' into `*client*'"
(setf (tooter:base *client*) (base *credentials*))
(setf (tooter:key *client*) (key *credentials*))
(setf (tooter:secret *client*) (secret *credentials*))
(setf (tooter:access-token *client*) (access-token *credentials*))
(setf (tooter:name *client*) +program-name+)
*client*)
(defun copy-credentials-from-client ()
"Copy credential data from `*client*' to `*credentials*'"
(setf (base *credentials*) (tooter:base *client*))
(setf (key *credentials*) (tooter:key *client*))
(setf (secret *credentials*) (tooter:secret *client*))
(setf (access-token *credentials*) (tooter:access-token *client*))
*credentials*)
(defun authorize-dialog-message ()
"Message printed when asking user to visit the autorization URL"
(_ "Please visit the address below."))
(defun open-catch-code-socket ()
"Returns a server socket on an arbitrary port, used to get the
authorization code from mastondo instance with its `return-url'
parameter, returns nil if a socket can not be opened."
(loop for port from 20000 to 50000 do
(let ((server (ignore-errors
(usocket:socket-listen "127.0.0.1" port))))
(when server
(return-from open-catch-code-socket
(values server port)))))
nil)
(defun catch-auth-code (socket)
"When an user authorize a client to access mastodon the server send
an http request to an arbitrary URI chosen by the user.
This URI contains the authorization code neede to make the client
trusted by the server. When tinmop starts the authorization process
opens a server on the local machine and asks the server to redirect
the user's browser to an URI (which contains the autorization code on
a query string) that points to the local machine. The server on the
local machine read the data from the browser'srequeste and get the
authorization code.
This function perfom the latest of this actions."
(unwind-protect
(let* ((stream (usocket:socket-stream (usocket:socket-accept socket)))
(line (read-line stream)))
(multiple-value-bind (matched query-string)
(cl-ppcre:scan-to-strings "code=\(.+\)" line)
(if matched
(first (cl-ppcre:split "(&)|(\\p{White_Space})" (first-elt query-string)))
nil)))
(usocket:socket-close socket)))
(defun make-redirect-url (port)
"This is part of the url where the browser will be redirect after
authorizations was performed with success."
(strcat "http://127.0.0.1:" (to-s port)))
(defun make-default-client ()
"Convenience funtion to build a `api-client' instance"
(make-instance 'api-client
:base (make-base-slot)
:name +program-name+))
(defun authorize ()
"Perform all the steps to authorize this application"
(setf *client* (make-default-client))
(if (credentials-complete-p)
(progn
(copy-credentials-to-client)
(tooter:authorize *client*)
(when (null (application-credentials))
(ui:error-dialog-immediate
(format nil
(_ "Credential invalid. Try to remove ~a and restart the software to authenticate again.")
(res:get-data-file +credentials-filename+)))))
(multiple-value-bind (server-socket server-port)
(open-catch-code-socket)
(setf *client* (make-default-client))
(setf (tooter:redirect *client*) (make-redirect-url server-port))
#+debug-mode (misc:dbg "Client ~a not authorized" *client*)
(multiple-value-bind (a url)
(tooter:authorize *client*)
(declare (ignore a))
(let* ((dialog-msg (authorize-dialog-message))
(save-item (_ "Save address"))
(open-item (_ "Open address"))
(choosen (ui:info-dialog-immediate (format nil "~a~%~a" dialog-msg url)
:buttons (list save-item open-item))))
(labels ((on-got-authorization-code (value)
(handler-case
(progn
(tooter:authorize *client* value)
(copy-credentials-from-client)
(dump-credentials)
(ui:notify (_ "This client has been authorized")))
(tooter:request-failed (error)
(ui:request-error-window error))
(error ()
(ui:error-dialog-immediate (_ "Got a generic error when registering client")))))
(notify-file-saved (filepath)
(ui:notify (format nil (_ "File ~a saved") filepath)))
(save-credentials ()
(let* ((message (_ "Please enter below the file where to save the address"))
(filepath (ui:input-dialog-immediate message)))
(cond
((null filepath)
(save-credentials))
((fs:file-exists-p filepath)
(if (ui:confirm-file-overwrite-dialog-immediate filepath)
(progn
(fs:dump-sequence-to-file url filepath)
(notify-file-saved filepath))
(save-credentials)))
(t
(fs:dump-sequence-to-file url filepath)
(notify-file-saved filepath))))))
(cond
((string= choosen open-item)
(os-utils:xdg-open url)
(if server-socket
(let ((authcode (catch-auth-code server-socket)))
(on-got-authorization-code authcode))
(ui:error-dialog-immediate (_ "Error: was not able to create server socket to listen for authorization code"))))
((string= choosen save-item)
(save-credentials)))))))))
(defun-w-lock favourite-status (status-id)
*client-lock*
"Favourite a status identified by `status-id'"
(tooter:favourite *client*
status-id))
(defun-w-lock unfavourite-status (status-id)
*client-lock*
"Unfavourite a status identified by `status-id'"
(tooter:unfavourite *client*
status-id))
(defun-w-lock reblog-status (status-id)
*client-lock*
"Reblog a status identified by `status-id'"
(tooter:reblog *client*
status-id))
(defun-w-lock unreblog-status (status-id)
*client-lock*
"Reblog a status identified by `status-id'"
(tooter:unreblog *client*
status-id))
(defun-w-lock get-timeline (kind &key local only-media max-id since-id min-id (limit 20))
*client-lock*
"Get messages (status) belonging to a timeline
- kind: one of
db:+federated-timeline+
db:+home-timeline+
- local: get status local to the instance the client is connected to
- only-media get status with attachments only
- max-id get status until this id
- min-id starts getting messages newer than this id
- since-id cut the messages got starting drom this id
- limit gets a maimum of messages up to this value."
(tooter:timeline *client*
kind
:local local
:only-media only-media
:max-id max-id
:since-id since-id
:min-id min-id
:limit limit))
(defun-w-lock update-timeline (timeline kind
folder
&key
local only-media max-id since-id
min-id
(limit 20))
*client-lock*
"Update a timeline, this function will fetch new messages and generate and event to
update the program reflectings the changes in the timeline (saves
messages in the database etc.)"
(let* ((timeline-statuses (get-timeline kind
:local local
:only-media only-media
:max-id max-id
:since-id since-id
:min-id min-id
:limit limit))
(trees (flatten (loop for node-status in timeline-statuses collect
(expand-status-tree node-status))))
(event (make-instance 'program-events:update-timeline-event
:payload trees
:timeline-type timeline
:folder folder
:localp local
:min-id min-id)))
(program-events:push-event event)))
(defun-w-lock get-timeline-tag (tag &key min-id (limit 20))
*client-lock*
"Gets messages that contains tags identitgied by parameter `tag'"
(tooter:timeline-tag *client*
tag
:local nil
:only-media nil
:max-id nil
:since-id nil
:min-id min-id
:limit limit))
(defun-w-lock update-timeline-tag (tag folder &key min-id (limit 20))
*client-lock*
"Update a tag timeline, this function will fetch new messages (that
contains tag `tag') and generate and event to update the program
reflectings the changes in the timeline (saves messages in the
database etc.)"
(when tag
(let* ((timeline-statuses (get-timeline-tag tag
:min-id min-id
:limit limit))
(trees (flatten (loop for node-status in timeline-statuses collect
(expand-status-tree node-status))))
(update-timeline-event (make-instance 'program-events:update-timeline-event
:payload trees
:timeline-type db:+federated-timeline+
:folder folder
:localp nil
:min-id min-id)))
(program-events:push-event update-timeline-event))))
(defun tag-name (tag &key (return-empty-string-if-nil nil))
"Returns a convevient tag name from `tooter:tag'.
if `return-empty-string-if-nil' is non nil an apty tag (nil) will
become an emty string (\"\")
"
(let ((name (tooter:name tag)))
(or name
(if return-empty-string-if-nil
""
nil))))
(defun-w-lock update-subscribed-tags (all-tags &key min-id (limit 20))
*client-lock*
"Update all tage in the list `all-tags'"
(loop for tag in all-tags do
(let ((tag-folder (db:tag->folder-name tag)))
(update-timeline-tag tag
tag-folder
:limit limit
:min-id min-id))))
(defun-w-lock fetch-remote-status (status-id)
*client-lock*
"Fetch a single status identified by status-id and generate an event
`fetch-remote-status-event' that, in turn will save the status to the
database."
(when-let* ((status (tooter:find-status *client* status-id))
(event (make-instance 'program-events:fetch-remote-status-event
:payload status)))
(program-events:push-event event)))
(defun-w-lock get-remote-status (status-id)
*client-lock*
"Get a single status identifird bu status-id"
(ignore-errors
(tooter:find-status *client* status-id)))
(defun-w-lock get-status-context (status-id) *client-lock*
"Get aparent and a child of a status (identified by status-id), if exists"
(tooter:context *client* status-id))
(defun-w-lock send-status (content in-reply-to-id attachments subject visibility)
*client-lock*
"Send a status
- content the actual text of the message
- in-reply-to-id status-id of the message you are replying to (or nil
if this message is not a reply
- attachments a list of file path to attach or nil il no attachments
to this message exists
- subject the subkec of this message
- visibility one of `swconf:*allowed-status-visibility*'"
(tooter:make-status *client*
content
:in-reply-to in-reply-to-id
:media (mapcar #'fs:namestring->pathname attachments)
:spoiler-text subject
:visibility visibility))
(defun-w-lock follow-user (user-id)
*client-lock*
"Follow user identified by user-id"
(tooter:follow *client* user-id))
(defun-w-lock unfollow-user (user-id)
*client-lock*
"Unfollow user identified by user-id"
(tooter:unfollow *client* user-id))
(defun-w-lock follow-requests ()
*client-lock*
"Gets the request tio follow the user of this client"
(let ((requests (tooter:follow-requests *client*)))
(values requests
(mapcar #'tooter:account-name requests))))
(defun-w-lock accept-follow-request (user-id)
*client-lock*
"Accept a follow request from user identified by `user-id'"
(when user-id
(tooter:accept-request *client* user-id)))
(defun-w-lock reject-follow-request (user-id)
*client-lock*
"Reject a follow request from user identified by `user-id'"
(when user-id
(tooter:reject-request *client* user-id)))
(defclass conversation-tree ()
((id
:initform nil
:initarg :id
:accessor id
:type string
:documentation "The conversation ID")
(status-tree
:initform nil
:initarg :status-tree
:accessor status-tree
:type list
:documentation "A flat list of statuses that forms the conversation tree")
(last-status
:initform nil
:initarg :last-status
:accessor last-status
:type tooter:status
:documentation "The lastest status that forms this conversation")
(root
:initform nil
:initarg :root
:accessor root
:type tooter:status
:documentation "The first status that forms this conversation"))
(:documentation "Represents a tree of message belonging to a conversation"))
(defmethod print-object ((object conversation-tree) stream)
(print-unreadable-object (object stream :type t)
(with-accessors ((id id)
(status-tree status-tree)
(root root)) object
(format stream "id: ~a tree: ~a root ~a" id status-tree root))))
(defgeneric conversation-root-id (object))
(defmethod conversation-root-id ((object conversation-tree))
"Status id of the root of a conversation tree"
(tooter:id (root object)))
(defun-w-lock conversations (&key
(min-id nil)
(since-id nil)
(max-id nil)
(limit 20)
(root-only nil))
*client-lock*
"Get trees of conversations
- max-id get status until this id
- min-id starts getting messages newer than this id
- since-id cut the messages got starting drom this id
- limit gets a maimum of messages up to this value
- root-only if non nil do not return the whole trees just the root of each."
(let ((conversations (tooter:conversations *client*
:min-id min-id
:since-id since-id
:max-id max-id
:limit limit)))
(loop for conversation in conversations collect
(let* ((conversation-id (tooter:id conversation))
(last-status (tooter:last-status conversation))
(conversation-tree (and (not root-only)
(expand-status-tree last-status)))
(sorted-tree (sort conversation-tree
(lambda (a b)
(string< (tooter:id a)
(tooter:id b)))))
(root-message (if (not root-only)
(first sorted-tree)
(climb-fetch-statuses last-status))))
(make-instance 'conversation-tree
:last-status last-status
:id conversation-id
:status-tree sorted-tree
:root root-message)))))
(defun expand-conversations-tree (message-root-id)
"fetch all the tree that stars from `message-root-id',
i.e. `message-root-id' is root for said tree."
(expand-status-tree message-root-id))
(defun-w-lock delete-conversation (conversation-id)
*client-lock*
"Delete a conversation identified by `conversation-id'"
(tooter:delete-conversation *client* conversation-id))
(defun-w-lock make-report (account-id status-id comment forward)
*client-lock*
"Report an user (identified by `account-id') and a
status (identified by `status-id') to and instance admin, if `forward'
is non nil the report will be forwarded to the non local admin where
the account belongs."
(tooter:make-report *client*
account-id
:statuses (list status-id)
:comment comment
:forward forward))
(defun-w-lock get-activity ()
*client-lock*
"Get instance stats"
(tooter:get-activity *client*))
(defun-w-lock application-credentials ()
*client-lock*
"Verify the credentials to log into the server with the instance,
returns nil if the credentials are invalid"
(tooter:verify-app-credentials *client*))
(defun-w-lock bookmarks (&key
(min-id nil)
(since-id nil)
(max-id nil)
(limit 20))
*client-lock*
"List Bookmarked statuses.
- max-id get status until this id
- min-id starts getting messages newer than this id
- since-id cut the messages got starting drom this id
- limit gets a maimum of messages up to this value."
(tooter:bookmarks *client*
:min-id min-id
:since-id since-id
:max-id max-id
:limit limit))
(defun-w-lock bookmark (id)
*client-lock*
"Bookmark a status identified by `id'"
(assert (stringp id))
(tooter:bookmark *client* id))
(defun-w-lock unbookmark (id)
*client-lock*
"Unbokmark a status identified by `id'"
(assert (stringp id))
(tooter:unbookmark *client* id))
(defun-w-lock polls (id)
*client-lock*
"Get a poll identified by `id'"
(assert (stringp id))
(tooter:polls *client* id))
(defgeneric climb-fetch-statuses (object &optional branch))
(defmethod climb-fetch-statuses ((object tooter:status) &optional (branch ()))
(climb-fetch-statuses (tooter:id object) branch))
(defmethod climb-fetch-statuses ((object string) &optional (branch ()))
"Starting from 'object' (a toot's ID) climbs messages tree, fetch
parent status from the internet if needed until the message root is
found, return two values the root of the tree and the statuses climbed
while reaching the root (a branch, or portion of a branch if
node-status-id is not a leaf)."
(flet ((reply-id (status)
(tooter:in-reply-to-id status)))
(when-let ((status (get-remote-status object)))
(if (null (reply-id status)) ; the root
(values status (push status branch))
(progn
(climb-fetch-statuses (reply-id status)
(push status branch)))))))
(defun make-id= (&optional (test #'string=))
"Returns a comparator function that checks for id equality"
(lambda (a b) (funcall test (tooter:id a) (tooter:id b))))
(defgeneric expand-status-tree (object))
(defmethod expand-status-tree ((object tooter:status))
(expand-status-tree (tooter:id object)))
(defmethod expand-status-tree ((object string))
"Given a status id returns the complete mesaages tree this status belong."
(multiple-value-bind (root fetched-branch)
(climb-fetch-statuses object)
(let ((res (copy-list fetched-branch)))
(labels ((descend (node-id)
(when node-id
(let* ((context (get-status-context node-id))
(children (tooter:descendants context)))
(loop for child in children do
(when (not (find child res :test (make-id=)))
(push child res)
(descend (tooter:id child))))))))
(descend root)
res))))
(defun make-placeholder-tag-histogram ()
"Make an empty `tooter:tag-history' (empty means all counts are 0
and day is current time)"
(make-instance 'tooter:tag-history
:account-count 0
:use-count 0
:day (get-universal-time)))
(defun init ()
"Initialize the client, prepare it for `authorize'."
(flet ((credentials-filename ()
(handler-bind ((error
(lambda (e)
(invoke-restart 'res:return-home-filename e))))
(res:get-data-file +credentials-filename+))))
(let ((resource-file (credentials-filename)))
(if (not (fs:file-exists-p resource-file))
(progn
#+debug-mode (misc:dbg (_ "Initializing empty credentials file in ~a")
resource-file)
(fs:dump-sequence-to-file (serialize (make-instance 'credentials))
resource-file)
(init))
(setf *credentials* (deserialize t resource-file))))))

66
src/box.lisp Normal file
View File

@ -0,0 +1,66 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :box)
(defclass box ()
((contents
:initform nil
:initarg :contents
:accessor contents
:documentation "the thing inside the box"))
(:documentation "A generic object that contains a value"))
(defmethod print-object ((object box) stream)
(print-unreadable-object (object stream :type t)
(format stream "~a" (contents object))))
(defun boxp (thing)
(typep thing 'box))
(defun box (thing)
"Put `thing' in a box, if thing is aalready a box return `thing'."
(if (boxp thing)
thing
(make-instance 'box :contents thing)))
(defun unbox (thing)
"Unbox `thing' and returns the value contained, if `thing' is not a
box return `thing'."
(if (boxp thing)
(contents thing)
thing))
(defsetf unbox (object) (val)
`(setf (contents ,object) ,val))
(defun dboxp (thing)
"Return non nil id `thing' is a box that contains a box (double box)."
(and (boxp thing)
(boxp (contents thing))))
(defun dbox (thing)
"Box `thing' in a double box."
(if (dboxp thing)
thing
(make-instance 'box :contents (box thing))))
(defun dunbox (object)
"Unbox a double box"
(contents (contents object)))
(defsetf dunbox (object) (val)
`(setf (contents (contents ,object)) ,val))

352
src/bs-tree.lisp Normal file
View File

@ -0,0 +1,352 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :bs-tree)
(defclass node ()
((parent
:initarg :parent
:initform nil
:accessor parent)
(data
:initarg :data
:initform nil
:accessor data)
(left
:initarg :left
:initform nil
:accessor left)
(right
:initarg :right
:initform nil
:accessor right)))
(defgeneric node->string (object))
(defgeneric search (object datum &key key key-datum compare equal))
(defgeneric search-opt (object datum &key key key-datum compare equal candidate))
(defgeneric insert (object datum &key key key-datum compare equal &allow-other-keys))
(defgeneric leafp (object))
(defgeneric all-children-leaf-p (object))
(defgeneric map (object function))
(defgeneric map-node (object function))
(defgeneric %walk (object function args))
(defgeneric walk (object function &rest args))
(defgeneric bstp (object &key comp-fn key))
(defgeneric node->dot (object))
(defgeneric reconstruct-parent (object &optional parent))
(defgeneric find-max-node (object))
(defmethod data ((object (eql nil)))
nil)
(defmethod parent ((object (eql nil)))
nil)
(defmethod print-object ((object node) stream)
(format stream "~a" (node->string object)))
(defmethod node->string ((object (eql nil)))
"nil")
(defmethod node->string ((object node))
(if (null (data object))
""
(format nil "~a ~% [~a] [~a]"
(data object)
(node->string (left object))
(node->string (right object)))))
(defmethod leafp ((object node))
(null (data object)))
(defmethod all-children-leaf-p ((object node))
(and (leafp (left object))
(leafp (right object))))
(defmethod search ((object node) datum &key (key #'identity)
(key-datum #'identity) (compare #'<) (equal #'=))
(if (leafp object)
nil
(cond
((funcall equal (%key key (data object)) (%key key-datum datum))
object)
((funcall compare (%key key-datum datum) (%key key (data object)))
(search (left object) datum :key key :key-datum key-datum
:compare compare :equal equal))
(t
(search (right object) datum :key key :key-datum key-datum
:compare compare :equal equal)))))
(defmethod search-opt ((object node) datum &key (key #'identity)
(key-datum #'identity) (compare #'<) (equal #'=)
(candidate nil))
(if (leafp object)
(if (and candidate (funcall equal (%key key (data candidate)) (%key key-datum datum)))
candidate
nil)
(cond
((funcall compare (%key key (data object)) (%key key-datum datum))
(search-opt (left object) datum :key key :key-datum key-datum
:compare compare :equal equal :candidate candidate))
(t
(search-opt (right object) datum :key key :key-datum key-datum
:compare compare :equal equal :candidate object)))))
(defun make-node (data left right parent)
(make-instance 'node :left left :right right :data data :parent parent))
(defun make-leaf (parent)
(make-instance 'node :parent parent :left nil :right nil))
(defun make-root-node (datum)
(let* ((tree (make-node datum nil nil nil))
(l-leaf (make-leaf tree))
(r-leaf (make-leaf tree)))
(setf (left tree) l-leaf
(right tree) r-leaf)
tree))
(defun %key (key-fn a)
(funcall key-fn a))
(alexandria:define-constant +data+ :data :test #'eq)
(alexandria:define-constant +left+ :left :test #'eq)
(alexandria:define-constant +right+ :right :test #'eq)
(alexandria:define-constant +parent+ :parent :test #'eq)
(defmethod to-sexp ((object node))
(let ((*print-circle* t))
(list +data+ (to-sexp (data object))
+left+ (to-sexp (left object))
+right+ (to-sexp (right object))
+parent+ (to-sexp (data (parent object))))))
(defmethod from-sexp ((object node) sexp)
(declare (ignorable object))
(labels ((%from-sexp (sexp)
(if (null sexp)
(make-leaf nil)
(make-node (getf sexp +data+)
(from-sexp object (getf sexp +left+))
(from-sexp object (getf sexp +right+)) nil))))
(let ((new-tree (%from-sexp sexp)))
(reconstruct-parent new-tree))))
(defmacro %make-new-node (make-node-fn node data left right parent args)
`(,make-node-fn ,data ,left ,right ,parent
,@(loop for i in args collect
`(,i ,node))))
(defmacro with-insert-local-function ((make-left-node-fn
make-right-node-fn
make-leaf-node-fn
make-leaf-fn
left-descend-fn
right-descend-fn)
&body body)
(let ((insert-fn (alexandria:format-symbol t "%INSERT")))
`(labels ((,insert-fn (node datum key key-datum compare equal)
(if (leafp node)
(let* ((new-node (,make-leaf-node-fn
datum nil nil (parent node)))
(l-leaf (,make-leaf-fn new-node))
(r-leaf (,make-leaf-fn new-node)))
(setf (data new-node) datum
(left new-node) l-leaf
(right new-node) r-leaf)
new-node)
(cond
((funcall equal (%key key (data node)) (%key key-datum datum))
node)
((funcall compare (%key key-datum datum) (%key key (data node)))
,(let ((a `(let ((new-node (,make-left-node-fn
(data node)
(,insert-fn (left node) datum key
key-datum compare equal)
(right node)
(parent node))))
(setf (parent (right new-node)) new-node
(parent (left new-node)) new-node)
new-node)))
(if left-descend-fn
`(,left-descend-fn ,a)
a)))
(t
,(let ((a `(let ((new-node (,make-right-node-fn
(data node)
(left node)
(,insert-fn (right node) datum key
key-datum compare equal)
(parent node))))
(setf (parent (right new-node)) new-node
(parent (left new-node)) new-node)
new-node)))
(if right-descend-fn
`(,right-descend-fn ,a)
a)))))))
,@body)))
(defmethod insert ((object node) datum &key (key #'identity) (key-datum #'identity)
(compare #'<) (equal #'=))
(with-insert-local-function (make-node make-node make-node make-leaf nil nil)
(%insert object datum key key-datum compare equal)))
(defmethod map ((object node) function)
(with-accessors ((data data) (left left) (right right)) object
(if (leafp object)
(make-leaf nil)
(make-node (funcall function data) (map left function)
(map right function) nil))))
(defmethod map-node ((object node) function)
(with-accessors ((color color) (data data) (left left) (right right)) object
(if (leafp object)
(funcall function object (make-leaf object))
(funcall function object (make-node data
(map-node left function)
(map-node right function) nil)))))
(defmethod %walk ((object node) function args)
(with-accessors ((color color) (data data) (left left) (right right)) object
(when (not (leafp object))
(apply function object args)
(%walk left function args)
(%walk right function args))))
(defmethod %walk ((object node) function (args (eql nil)))
(with-accessors ((color color) (data data) (left left) (right right)) object
(when (not (leafp object))
(funcall function object)
(%walk left function args)
(%walk right function args))))
(defmethod %walk ((object (eql nil)) function args)
(apply function object args))
(defmethod walk ((object node) function &rest args)
(with-accessors ((color color) (data data) (left left) (right right)) object
(when (not (leafp object))
(apply function object args)
(%walk left function args)
(%walk right function args))))
(defmethod walk ((object (eql nil)) function &rest args)
(apply function object args))
(defun gather-all (node &key (add-root t))
(let ((res nil))
(when (not (leafp node))
(walk (left node) #'(lambda (n) (push (data n) res)))
(walk (right node) #'(lambda (n) (push (data n) res)))
(and add-root (push (data node) res)))
res))
(defmethod bstp ((object node) &key (comp-fn #'<) (key #'identity))
(labels ((balanced (node)
(with-accessors ((left left) (right right)) node
(if (not (leafp node))
(let ((left-children (and left (gather-all left)))
(right-children (and right (gather-all right)))
(pivot (funcall key (data node))))
(cond
((and (null left-children) (null right-children))
t);; leaf node, always balanced
((and left-children right-children)
(and
(every #'(lambda (a) (funcall comp-fn (funcall key a) pivot))
left-children)
(every #'(lambda (a) (funcall comp-fn pivot (funcall key a)))
right-children)
'a))
((null left-children)
(and (every #'(lambda (a) (funcall comp-fn pivot (funcall key a)))
right-children))
'l)
((null right-children)
(every #'(lambda (a) (funcall comp-fn (funcall key a) pivot))
left-children)
'r)))
(misc:dbg "leaf root ~a" (data node))))))
(let ((res nil))
(walk object #'(lambda (n) (push
(cons (data n) (or (balanced n) '(nil)))
res)))
(every #'cdr res))))
(defmethod node->dot ((object node))
(labels ((nodes ()
(append
(list
`(:node ((:id ,(format nil "~a" (data object)))
(:label ,(format nil "~ap~a" (data object)
(data (parent object)))))))
(if (not (leafp (left object)))
(node->dot (left object))
(list
`(:node ((:id ,(format nil "nil-l~a" (data object)))
(:label "nil")))))
(if (not (leafp (right object)))
(node->dot (right object))
(list
`(:node ((:id ,(format nil "nil-r~a" (data object)))
(:label "nil")))))))
(edges ()
(append
(if (data (left object))
(list `(:edge
((:from ,(format nil "~a" (data object)))
(:to ,(format nil "~a" (data (left object)))))))
(list `(:edge
((:from ,(format nil "~a" (data object)))
(:to ,(format nil "nil-l~a" (data object)))))))
(if (data (right object))
(list `(:edge
((:from ,(format nil "~a" (data object)))
(:to ,(format nil "~a" (data (right object)))))))
(list `(:edge
((:from ,(format nil "~a" (data object)))
(:to ,(format nil "nil-r~a" (data object))))))))))
(append (nodes) (edges))))
(defmethod reconstruct-parent ((object node) &optional (parent (parent object)))
(with-accessors ((data data) (left left) (right right)) object
(if (leafp object)
(make-leaf parent)
(make-node data
(reconstruct-parent left object)
(reconstruct-parent right object) parent))))
(defmethod find-max-node ((object node))
(if (leafp (right object))
object
(find-max-node (right object))))

96
src/command-line.lisp Normal file
View File

@ -0,0 +1,96 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/][http://www.gnu.org/licenses/]].
(in-package :command-line)
(defun print-version ()
(format t (_ "~a version ~a~%") +program-name+ +program-version+))
(defmacro gen-opts ()
`(opts:define-opts
(:name :help
:description (_ "Print help and exit")
:short #\h
:long "help")
(:name :version
:description (_ "Print program information and exit")
:short #\v
:long "version")
(:name :folder
:description (_ "Starting folder")
:short #\f
:arg-parser #'identity
:meta-var (_ "FOLDER-NAME")
:long "folder")
(:name :timeline
:description (_ "Starting timeline")
:short #\t
:meta-var (_ "TIMELINE-NAME")
:arg-parser #'identity
:long "timeline")
(:name :update-timeline
:description (_ "Update timeline")
:short #\u
:long "update-timeline")
(:name :check-follows-requests
:description (_ "Check follows requests")
:short #\c
:long "check-follows-requests")
(:name :execute
:description (_ "Execute script")
:short #\e
:arg-parser #'identity
:meta-var (_ "SCRIPT-FILE")
:long "execute-script")))
(defparameter *start-folder* nil)
(defparameter *start-timeline* nil)
(defparameter *update-timeline* nil)
(defparameter *script-file* nil)
(defparameter *check-follow-requests* nil)
(defun exit-on-error (e)
(format *error-output* "~a~%" e)
(os-utils:exit-program 1))
(defun manage-opts ()
(handler-bind ((opts:unknown-option #'exit-on-error)
(opts:missing-arg #'exit-on-error)
(opts:missing-required-option #'exit-on-error))
(gen-opts)
(let ((options (opts:get-opts)))
(when (getf options :help)
(print-version)
(opts:describe :usage-of +program-name+)
(os-utils:exit-program))
(when (getf options :version)
(print-version)
(os-utils:exit-program))
(when (getf options :folder)
(setf *start-folder* (getf options :folder)))
(when (getf options :timeline)
(setf *start-timeline* (getf options :timeline)))
(when (getf options :update-timeline)
(setf *update-timeline* (getf options :update-timeline)))
(when (getf options :execute)
(setf *script-file* (getf options :execute)))
(when (getf options :check-follows-requests)
(setf *check-follow-requests* (getf options :check-follows-requests))))))

486
src/command-window.lisp Normal file
View File

@ -0,0 +1,486 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2018 cage
;; 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/>.
(in-package :command-window)
(defclass command-window (wrapper-window point-tracker)
((command-line
:initform ()
:initarg :command-line
:accessor command-line
:documentation "A list of keys so far inserted by the user")
(error-message
:initform nil
:initarg :error-message
:accessor error-message
:documentation "Error message to be printed")
(error-message-bg
:initform nil
:initarg :error-message-bg
:accessor error-message-bg
:documentation "Error message background color")
(error-message-fg
:initform nil
:initarg :error-message-fg
:accessor error-message-fg
:documentation "Error message foreground color")
(error-message-attributes
:initform nil
:initarg :error-message-attributes
:accessor error-message-attributes
:documentation "Error message attributes (bold, blink etc.)")
(info-message
:initform nil
:initarg :info-message
:accessor info-message
:documentation "Information message to be printed")
(info-message-bg
:initform nil
:initarg :info-message-bg
:accessor info-message-bg
:documentation "Info message background color")
(info-message-fg
:initform nil
:initarg :info-message-fg
:accessor info-message-fg
:documentation "Info message foreground color")
(info-message-attributes
:initform nil
:initarg :info-message-attributes
:accessor info-message-attributes
:documentation "Info message attributes (bold, blink etc.)")
(commands-separator
:initform " "
:initarg :commands-separator
:accessor commands-separator
:documentation "The text printed to separates each key in command")
(suggestions-win
:initform nil
:initarg :suggestions-win
:accessor suggestions-win
:documentation "The windows that print contect stuccesions to
user (e.g. autocomplete path")
(history-position
:initarg :history-position
:accessor history-position
:documentation "Current positions in the history of commands")
(event-to-answer
:initform nil
:initarg :event-to-answer
:accessor event-to-answer
:documentation "This is the event that was triggered by a function
that instruct the command window to ask user for an input. This
event is inpected to get the prompt and, after the input is
complete, a slot is setted with such input, then another event
`user-input-string-event' is generated to notify (via a condition
variable) the thread that generated `event-to-answer' the fact
that the input is complete.")
(input-mode
:initform :keybinding
:initarg :input-mode
:accessor input-mode
:documentation "The mode of accepting input for this window. Can
be either `:keybinding' or `:string'. the former for key command the latter for free input (e.g filepath, username, etc")))
(defmethod initialize-instance :after ((object command-window) &key &allow-other-keys)
(with-accessors ((command-line command-line)
(commands-separator commands-separator)
(error-message error-message)
(history-position history-position)
(prompt prompt)
(suggestions-win suggestions-win)) object
;; poor man cache...
(setf specials:*keybindings-suggestions-window* (keybindings-window:init))
(setf specials:*strings-suggestions-window* (complete-window:init))
(set-keybinding-mode object)
object))
(defun set-history-most-recent (window prompt)
(with-accessors ((command-line command-line)
(history-position history-position)) window
(setf history-position
(1+ (db:most-recent-history-id prompt)))))
(defmethod refresh-config :after ((object command-window))
(with-accessors ((error-message-bg error-message-bg)
(error-message-fg error-message-fg)
(error-message-attributes error-message-attributes)
(info-message-bg info-message-bg)
(info-message-fg info-message-fg)
(info-message-attributes info-message-attributes)) object
(let* ((w (win-width *main-window*))
(h +command-window-height+)
(x 0)
(y (1- (win-height *main-window*))))
(refresh-config-colors object swconf:+key-command-window+)
(multiple-value-bind (bg fg value)
(swconf:command-separator-config-values)
(multiple-value-bind (error-bg error-fg error-attributes)
(swconf:command-error-message-colors)
(multiple-value-bind (info-bg info-fg info-attributes)
(swconf:command-info-message-colors)
(setf error-message-bg error-bg)
(setf error-message-fg error-fg)
(setf error-message-attributes error-attributes)
(setf info-message-bg info-bg)
(setf info-message-fg info-fg)
(setf info-message-attributes info-attributes)
(setf (point-fg object) (win-bgcolor object))
(setf (point-bg object) (win-fgcolor object))
(setf (commands-separator object)
(make-tui-string value
:fgcolor fg
:bgcolor bg))
(win-resize object w h)
(win-move object x y)
object))))))
(defmethod calculate ((object command-window) dt)
(with-accessors ((suggestions-win suggestions-win)) object
(when suggestions-win
(calculate suggestions-win dt))))
(defun draw-keybinding-mode (win)
"Draw window `win' accepting key commands"
(with-accessors ((command-line command-line)
(point-position point-position)
(point-bg point-bg)
(point-fg point-fg)
(prompt prompt)) win
(let* ((length-cmd-line (length command-line))
(no-prompt-point-pos (no-prompt-point-pos win))
(cursor-value (if (and (> length-cmd-line 0)
(< no-prompt-point-pos
length-cmd-line))
(elt command-line no-prompt-point-pos)
#\Space)))
(print-text win prompt 0 0)
(when command-line
(print-text win command-line (length prompt) 0))
(print-text win
cursor-value
point-position
0
:fgcolor point-fg
:bgcolor point-bg))))
(defmethod draw ((object command-window))
(with-accessors ((command-line command-line)
(commands-separator commands-separator)
(error-message-bg error-message-bg)
(error-message-fg error-message-fg)
(error-message-attributes error-message-attributes)
(error-message error-message)
(info-message-bg info-message-bg)
(info-message-fg info-message-fg)
(info-message info-message)
(info-message-attributes info-message-attributes)
(suggestions-win suggestions-win)) object
(when suggestions-win
(draw suggestions-win))
(win-clear object :redraw nil)
(cond
(error-message
(print-text object error-message 0 0
:bgcolor error-message-bg
:fgcolor error-message-fg
:attributes error-message-attributes))
(info-message
(print-text object info-message 0 0
:bgcolor info-message-bg
:fgcolor info-message-fg
:attributes info-message-attributes))
(t
(if (keybindings-mode-p object)
(when command-line
(let ((advance 0))
(loop for (command . rest) on command-line while rest do
(print-text object command advance 0)
(incf advance (length command))
(print-text object commands-separator advance 0)
(incf advance (text-width commands-separator)))
(print-text object (last-elt command-line) advance 0)))
(draw-keybinding-mode object))))
(win-refresh object)))
(defgeneric enqueue-command (object command decode-key))
(defgeneric complete-at-point (object))
(defgeneric show-candidate-completion (object))
(defgeneric add-error-message (object message))
(defgeneric add-info-message (object message))
(defun manage-command-event (command-window event)
"Intercept UI events in keybindg mode"
(with-accessors ((command-line command-line)
(suggestions-win suggestions-win)) command-window
;; some envents should by intercepted by command window
(cond
((eq :control-left event) ; suggestion win pagination
(move-suggestion-page-left command-window))
((eq :control-right event) ; suggestion win pagination
(move-suggestion-page-right command-window))
((eq :backspace event) ; delete last command or char
(setf command-line (safe-all-but-last-elt command-line))
(when-let ((last-command (safe-last-elt command-line)))
(setf command-line (safe-all-but-last-elt command-line))
(enqueue-command command-window last-command nil)))
(t
(enqueue-command command-window event t)))))
(defun update-suggestions (window key-decoded)
"Update suggestion window"
(with-accessors ((command-line command-line)
(suggestions-win suggestions-win)) window
;; if command-line is not null we are in the middle of a command
;; so no need to update the slot of suggestion-win with a new tree
(if command-line
(suggestions-window:update-suggestions suggestions-win
key-decoded
:tree nil)
(let* ((focused-keybindings (main-window:focused-keybindings specials:*main-window*))
(found-subtree (and focused-keybindings
(suggestions-window:update-suggestions suggestions-win
key-decoded
:tree
focused-keybindings))))
(or found-subtree
(suggestions-window:update-suggestions suggestions-win
key-decoded
:tree *global-keymap*))))))
(defmethod enqueue-command ((object command-window) command decode-key-p)
"Enqueue and process, if possibl,e `command` object, if decode-key
is not null decode key to something more human readable."
(with-accessors ((command-line command-line)
(info-message info-message)
(error-message error-message)
(suggestions-win suggestions-win)) object
(when (null suggestions-win)
(setf suggestions-win (keybindings-window:init)))
(win-show suggestions-win)
(let* ((key-decoded (if decode-key-p
(decode-key-event command)
command))
(found-subtree (update-suggestions object key-decoded)))
(setf error-message nil)
(setf info-message nil)
(cond
((null found-subtree)
(let ((missing-command (format nil "~s" (lcat command-line
(list key-decoded)))))
(restart-case
(error 'conditions:command-not-found
:command missing-command)
(print-error (e)
(declare (ignore e))
(win-hide suggestions-win)
(setf suggestions-win nil)
(setf command-line nil)
(setf error-message
(format nil
(_ "Error: command ~a not found")
missing-command))))))
((functionp found-subtree)
(win-hide suggestions-win)
(setf suggestions-win nil)
(setf command-line nil)
(funcall found-subtree))
(t
(setf command-line (reverse command-line))
(push key-decoded command-line)
(setf command-line (reverse command-line))))))
object)
(defmethod complete-at-point ((object command-window))
"Complete input at point (string mode only)"
(with-accessors ((command-line command-line)
(suggestions-win suggestions-win)) object
(when (null suggestions-win)
(setf suggestions-win (complete-window:init)))
(win-show suggestions-win)
(multiple-value-bind (candidates common-prefix)
(suggestions-window:update-suggestions suggestions-win
command-line)
(if candidates
(progn
(when (length= candidates 1)
(win-hide suggestions-win))
(if common-prefix
(setf command-line common-prefix)
(setf command-line (complete:shortest-candidate candidates)))
(move-point-to-end object command-line))
(win-hide suggestions-win))))
object)
(defmethod show-candidate-completion ((object command-window))
(with-accessors ((command-line command-line)
(suggestions-win suggestions-win)) object
(when (null suggestions-win)
(setf suggestions-win (complete-window:init)))
(let ((candidates (suggestions-window:update-suggestions suggestions-win
command-line)))
(if candidates
(win-show suggestions-win)
(win-hide suggestions-win)))))
(defmethod add-error-message ((object command-window) message)
(setf (error-message object) message)
(draw object))
(defmethod add-info-message ((object command-window) message)
(setf (info-message object) message)
(draw object))
(defun move-suggestion-page (win offset)
"Paginate win (suggestion window) by offset, will not go past the numer of pages."
(with-accessors ((suggestions-win suggestions-win)) win
(when suggestions-win
(with-accessors ((current-page suggestions-window:current-page)
(paginated-info suggestions-window:paginated-info)) suggestions-win
(setf current-page (clamp (+ offset current-page)
0
(1- (length paginated-info))))))))
(defun move-suggestion-page-left (win)
(move-suggestion-page win -1))
(defun move-suggestion-page-right (win)
(move-suggestion-page win 1))
(defun fire-user-input-event (win)
"Generates an event to notify that the user inserted an input on the
command line."
(with-accessors ((event-to-answer event-to-answer)
(command-line command-line)) win
(assert event-to-answer)
(assert (typep event-to-answer
'program-events:program-event))
(let ((input-done-event (make-instance 'program-events:user-input-string-event
:payload
(program-events:payload event-to-answer)
:lock
(program-events:lock event-to-answer)
:condition-variable
(program-events:condition-variable event-to-answer))))
(setf (box:dunbox (program-events:payload input-done-event))
command-line)
(program-events:push-event input-done-event))))
(defun manage-string-event (command-window event)
"Manage UI events when `command-window` is in string mode"
(with-accessors ((command-line command-line)
(prompt prompt)
(history-position history-position)
(suggestions-win suggestions-win)) command-window
(flet ((set-history (new-id new-input)
(when (and new-id
new-input)
(setf history-position new-id)
(setf command-line new-input)))
(insert-in-history (prompt command-line)
(db:insert-in-history prompt command-line)
(set-history-most-recent command-window prompt)))
(cond
((eq :control-left event)
(move-suggestion-page-left command-window))
((eq :control-right event)
(move-suggestion-page-right command-window))
((eq :backspace event)
(setf command-line (delete-at-point command-window command-line :direction :left))
(show-candidate-completion command-window))
((eq :dc event)
(setf command-line (delete-at-point command-window command-line :direction :right))
(show-candidate-completion command-window))
((eq :left event)
(move-point-left command-window))
((eq :right event)
(move-point-right command-window (length command-line)))
((eq :end event)
(move-point-to-end command-window command-line))
((eq :home event)
(move-point-to-start command-window))
((eq :up event)
(multiple-value-bind (new-id new-input)
(db:previous-in-history history-position prompt)
(set-history new-id new-input)))
((eq :down event)
(multiple-value-bind (new-id new-input)
(db:next-in-history history-position prompt)
(set-history new-id new-input)))
((characterp event)
(cond
((char= #\Newline event)
(insert-in-history prompt command-line)
(fire-user-input-event command-window)
(setf command-line nil)
(move-point-to-start command-window)
(set-keybinding-mode command-window))
((char= #\Tab event)
(complete-at-point command-window))
(t
(when (null suggestions-win)
(setf suggestions-win (complete-window:init)))
(win-show suggestions-win)
(setf command-line
(insert-at-point command-window event command-line))
(show-candidate-completion command-window)))))))
command-window)
(defun set-input-mode (win mode suggestions-cached-win)
"Set win (command window) mode: keybindings or string mode"
(assert (member mode '(:keybinding :string)))
(with-accessors ((suggestions-win suggestions-win)
(input-mode input-mode)) win
(setf input-mode mode)
(when suggestions-win
(win-hide suggestions-win))
(setf suggestions-win suggestions-cached-win)))
(defmacro gen-set-mode-function (fn-name mode suggestions-cached-win)
`(defun ,(format-fn-symbol t "set-~a-mode" fn-name) (win)
(set-input-mode win ,mode ,suggestions-cached-win)))
(gen-set-mode-function keybinding :keybinding specials:*keybindings-suggestions-window*)
(gen-set-mode-function string :string specials:*strings-suggestions-window*)
(defun keybindings-mode-p (win)
"Non nil if win is in keybings mode"
(eq (input-mode win)
:keybinding))
(defun manage-event (event)
"Manage UI event, these are not program events but events fired by
the curses library (croatoan)"
(if (keybindings-mode-p *command-window*)
(manage-command-event *command-window* event)
(manage-string-event *command-window* event))
(draw *command-window*))
(defun init ()
"Initialize the window"
(with-croatoan-window (croatoan-main-window *main-window*)
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
(setf *command-window*
(make-instance 'command-window
:croatoan-window low-level-window))
(refresh-config *command-window*)
*command-window*)))

70
src/complete-window.lisp Normal file
View File

@ -0,0 +1,70 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2018 cage
;; 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/>.
(in-package :complete-window)
(defclass complete-window (suggestions-window)
()
(:documentation "A window to shows the possible completion for an
user input"))
(defmethod calculate ((object complete-window) dt)
(declare (ignore object dt)))
(defmethod update-suggestions ((object complete-window) hint &key &allow-other-keys)
"List the possible expansion of `hint' using the function
`complete:*complete-function*'."
(with-accessors ((paginated-info paginated-info)) object
(multiple-value-bind (candidates common-prefix)
(funcall complete:*complete-function* hint)
(when candidates
(when-let ((batches (text-utils:box-fit-multiple-column candidates
(- (win-width object) 2)
(- (win-height object)
+box-height-diff+))))
(setf paginated-info batches)
(values candidates common-prefix))))))
(defmethod draw :after ((object complete-window))
(with-accessors ((keybindings-tree keybindings-tree)
(paginated-info paginated-info)
(current-page current-page)) object
(when-window-shown (object)
(win-clear object :redraw nil)
(win-box object)
(when paginated-info
(loop
for column in (elt paginated-info current-page)
with column-count = 1
do
(let ((column-size (length (first column))))
(loop
for row in column
with row-count = 1 do
(print-text object row column-count row-count)
(incf row-count))
(incf column-count column-size)))
(draw-pagination-info object))
(win-refresh object))))
(defun init ()
"Initialize a complete window"
(let* ((low-level-window (make-croatoan-window :draw-border t))
(high-level-window (make-instance 'complete-window
:croatoan-window low-level-window)))
(refresh-config high-level-window)
(win-hide high-level-window)
high-level-window))

149
src/complete.lisp Normal file
View File

@ -0,0 +1,149 @@
;;;; Copyright (c) 2003, 2004 Nikodemus Siivola, Julian Squires
;;;;
;;;; 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.
(in-package :complete)
(defparameter *complete-function* nil
"A function that get an hint and return two values:
- a list of entries that match that hint
- the common prefix of such candidates.
See: complete:directory-complete")
(defun shortest-candidate (candidates)
"candidates is a sorted list (by length) -> first of the list,
otherwise return candidates"
(and candidates
(if (listp candidates)
(first candidates)
candidates)))
(defun reduce-to-common-prefix (items)
(reduce #'text-utils:common-prefix items))
(defun pathname-directory-pathname (pathname)
"convenience function to make a pathname object to a directory"
(make-pathname :name nil :type nil
:defaults pathname))
(defun underlying-directory-p (pathname)
"Find the actual directory of pathname (i.e. resolve file link"
(case (file-kind pathname)
(:directory t)
(:symbolic-link
(file-kind (merge-pathnames (read-link pathname) pathname)))))
;;; We can't easily do zsh-style tab-completion of ~us into ~user, but
;;; at least we can expand ~ and ~user. The other bug here at the
;;; moment is that ~nonexistant will complete to the same as ~.
(defun tilde-expand-string (string)
"Returns the supplied string, with a prefix of ~ or ~user expanded
to the appropriate home directory."
(if (and (> (length string) 0)
(eql (schar string 0) #\~))
(flet ((chop (s)
(subseq s 0 (1- (length s)))))
(let* ((slash-index (loop for i below (length string)
when (eql (schar string i) #\/)
return i))
(suffix (and slash-index (subseq string slash-index)))
(uname (subseq string 1 slash-index))
(homedir (or (cdr (assoc :home (user-info uname)))
(chop (namestring
(or (probe-file (user-homedir-pathname))
(return-from tilde-expand-string
string)))))))
(concatenate 'string homedir (or suffix ""))))
string))
(defun directory-complete (string)
"Return two values completion of 'string' (non nil if can be completed) and "
(declare (simple-string string))
(let* ((string (tilde-expand-string string))
(dir (pathname-directory-pathname string))
(namefun (if (relative-pathname-p string)
#'namestring
(lambda (x) (namestring (merge-pathnames x))))))
(unless (and (underlying-directory-p dir)
(not (wild-pathname-p dir)))
(return-from directory-complete (values nil 0)))
(with-directory-iterator (next dir)
(when-let* ((all (loop
for entry = (next)
while entry collect
(funcall namefun entry)))
(re (text-utils:strcat "^" string))
(candidates (sort (remove-if-not (lambda (a) (cl-ppcre:scan re a))
all)
(lambda (a b) (< (length a)
(length b))))))
(values candidates
(reduce-to-common-prefix candidates))))))
(defun starts-with-clsr (hint)
(lambda (a)
(cl-ppcre:scan (text-utils:strcat "^" hint) a)))
(defun folder-complete (hint)
"Virtual messages folder in db not filesystem directory"
(when-let ((matching-folders (remove-if-not (starts-with-clsr hint)
(db:all-folders))))
(values matching-folders
(reduce-to-common-prefix matching-folders))))
(defun timeline-complete-fn (folder)
"Complete a messages timeline prefix"
(lambda (hint)
(let* ((all-timelines (if folder
(db:all-timelines-in-folder folder
:include-default-timelines t)
(db:default-timelines)))
(matching-timelines (remove-if-not (starts-with-clsr hint)
all-timelines)))
(values matching-timelines
(reduce-to-common-prefix matching-timelines)))))
(defmacro with-simple-complete (function-name all-choices-list-fn)
"Generate a complete function using function-name to build the name
the function and `all-choices-list-fn' as a function that returns a
list af all possible candidtae for completion."
(with-gensyms (matched)
`(defun ,(misc:format-fn-symbol t "~a" function-name) (hint)
(when-let ((,matched (remove-if-not (starts-with-clsr hint)
(funcall (function ,all-choices-list-fn)))))
(values ,matched
(reduce-to-common-prefix ,matched))))))
(with-simple-complete ignored-username-complete db:all-ignored-usernames)
(with-simple-complete username-complete db:all-usernames)
(with-simple-complete visibility-complete (lambda () swconf:*allowed-status-visibility*))
(with-simple-complete unfollowed-user-complete
(lambda () (db:all-unfollowed-usernames :remove-ignored t)))
(with-simple-complete followed-user-complete db:all-followed-usernames)
(with-simple-complete tags-complete (lambda ()
(mapcar #'db:tag->folder-name
(db:all-subscribed-tags-name))))
(with-simple-complete conversation-folder db:all-conversation-folders)

98
src/conditions.lisp Normal file
View File

@ -0,0 +1,98 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package conditions)
(defmacro defcond (type)
`(define-condition ,(alexandria:format-symbol t "TEXT-~a" (string-upcase type))
(,type)
((text
:initarg :text
:reader text))
(:documentation "Error that set text")))
(defcond error)
(defcond warning)
(define-condition not-implemented-error (text-error)
()
(:documentation "Error for not-implemented features"))
(define-condition null-reference (text-error)
()
(:documentation "Null reference"))
(define-condition out-of-bounds (error)
((seq
:initarg :seq
:reader seq)
(idx
:initarg :idx
:reader idx))
(:documentation "Error when you go out of bound"))
(define-condition length-error (text-error)
((seq
:initarg :seq
:reader seq))
(:documentation "Length error"))
(define-condition different-length-error (error)
((seq1
:initarg :seq1
:reader seq1)
(seq2
:initarg :seq2
:reader seq2))
(:report (lambda (condition stream)
(format stream "~a ~a" (seq1 condition) (seq2 condition))))
(:documentation "Length error"))
(define-condition column-not-found (error)
((table
:initform (_ "unknown")
:initarg :table
:reader table)
(row
:initform (_ "unknown")
:initarg :row
:reader row)
(column
:initarg :column
:reader column))
(:report (lambda (condition stream)
(format stream
"table ~s column ~s row ~s"
(table condition)
(column condition)
(row condition))))
(:documentation "Condition signalled when a database column does exists in table."))
(define-condition command-not-found (error)
((command
:initarg :command
:reader command))
(:report (lambda (condition stream)
(format stream "~s" (command condition))))
(:documentation "Condition signalled when a command the user inputed
was not found in keybindigs tree."))
(defmacro with-default-on-error ((default) &body body)
"Well i think it is the same as `ignore-error'"
`(handler-case
(progn ,@body)
(error () ,default)))

45
src/config.lisp.in Normal file
View File

@ -0,0 +1,45 @@
;; tinmop: an a mastodon client
;; Copyright (C) 2020 cage
;; 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/][http://www.gnu.org/licenses/]].
(defmacro with-return-untranslated ((untranslated) &body body)
`(handler-bind ((i18n-conditions:no-translation-table-error
(lambda (e)
(declare (ignore e))
(invoke-restart 'cl-i18n:return-untranslated))))
(handler-case
(progn ,@body)
(i18n-conditions:no-translation (e)
(declare (ignorable e))
#+debug-mode
(progn
(warn e)
,untranslated)
#-debug-mode ,untranslated))))
(defun _ (a)
"get translated string"
(with-return-untranslated (a)
(cl-i18n:translate a)))
(defun n_ (a b n)
"Get stranslated string with plural forms
- a the untranslated string template
- b the string template to return if no translation was found
- n the number of object mentioned in the string template"
(declare (ignore b))
(with-return-untranslated (a)
(cl-i18n:ntranslate a a n)))

78
src/constants.lisp Normal file
View File

@ -0,0 +1,78 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :constants)
(define-constant +help-about-message-template+
"~a
Copyright (C) 2019 cage
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. "
:test #'string=)
(define-constant +http-code-ok+ 200 :test #'=)
(define-constant +mime-type-jpg+ "image/jpeg" :test #'string=)
(define-constant +mime-type-png+ "image/png" :test #'string=)
(define-constant +mime-type-html+ "text/html" :test #'string=)
(define-constant +db-file+ "db.sqlite3" :test #'string=
:documentation "the filename of the database")
(define-constant +json-true+ "true" :test #'string=)
(define-constant +json-false+ "false" :test #'string=)
(define-constant +fps+ 20 :test #'=
:documentation "The redraw frequency in frame per second")
(define-constant +command-window-height+ 1 :test #'=)
(define-constant +starting-init-file+ "init.lisp" :test #'string=)
(define-constant +box-height-diff+ 3 :test #'=
:documentation "When fitting columns of text in a box
remove this rows from total height")
(define-constant +default-command-prompt+ "> " :test #'string=)
(define-constant +menu-button-ok+ "OK" :test #'string=)
(define-constant +status-public-visibility+ "public" :test #'string=)
(define-constant +status-direct-visibility+ "direct" :test #'string=)
(define-constant +folder-tag-prefix+ "#" :test #'string=
:documentation "The prefix for messages hashtag")
(define-constant +folder-direct-message-prefix+ "@" :test #'string=
:documentation "The prefix for direct message folder, unused")
(define-constant +mention-prefix+ "@" :test #'string=
:documentation "The prefix for a mention in a message")

162
src/conversations-window.lisp Normal file
View File

@ -0,0 +1,162 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :conversations-window)
(defclass conversations-window (focus-marked-window
simple-line-navigation-window
title-window
border-window)
((read-message-fg
:initarg :read-message-fg
:initform nil
:accessor read-message-fg
:documentation "Read message foreground color")
(read-message-bg
:initarg :read-message-bg
:initform nil
:accessor read-message-bg
:documentation "Read message background color")
(unread-message-fg
:initarg :unread-message-fg
:initform nil
:accessor unread-message-fg
:documentation "Unread message foreground color")
(unread-message-bg
:initarg :unread-message-bg
:initform nil
:accessor unread-message-bg
:documentation "unread message background color"))
(:documentation "The window that shows active conversation"))
(defmethod refresh-config :after ((object conversations-window))
(with-accessors ((croatoan-window croatoan-window)
(histogram-fg histogram-fg)
(read-message-fg read-message-fg)
(read-message-bg read-message-bg)
(selected-line-bg selected-line-bg)
(selected-line-fg selected-line-fg)
(unread-message-fg unread-message-fg)
(unread-message-bg unread-message-bg)) object
(let* ((theme-style (swconf:form-style swconf:+key-conversations-window+))
(fg (swconf:foreground theme-style))
(bg (swconf:background theme-style))
(selected-fg (swconf:selected-foreground theme-style))
(selected-bg (swconf:selected-background theme-style))
(width (- (win-width *main-window*)
(win-width *thread-window*)))
(y (win-height *tags-window*))
(height (- (win-height *main-window*)
(win-height *command-window*)
(win-height *tags-window*)))
(x 0))
(multiple-value-bind (fg-read bg-read)
(swconf:conversation-window-read-colors)
(multiple-value-bind (fg-unread bg-unread)
(swconf:conversation-window-unread-colors)
(setf read-message-bg bg-read)
(setf read-message-fg fg-read)
(setf unread-message-bg bg-unread)
(setf unread-message-fg fg-unread)
(setf (background croatoan-window)
(tui:make-background bg))
(setf (bgcolor croatoan-window) bg)
(setf (fgcolor croatoan-window) fg)
(setf selected-line-fg selected-fg)
(setf selected-line-bg selected-bg)
(win-resize object width height)
(win-move object x y)
object)))))
(defmethod draw :before ((object conversations-window))
(with-accessors ((rows rows)
(single-row-height single-row-height)
(top-row-padding top-row-padding)
(read-message-fg read-message-fg)
(read-message-bg read-message-bg)
(unread-message-fg unread-message-fg)
(unread-message-bg unread-message-bg)) object
(win-clear object)
(with-croatoan-window (croatoan-window object)
(loop
for y from (+ 2 top-row-padding) by single-row-height
for row-fields in (mapcar #'fields rows) do
(let ((attributes-to-read (if (= (db:messages-to-read row-fields)
0)
(attribute-dim)
(attribute-bold))))
(print-text object
(text-utils:to-s (db:messages-to-read row-fields))
1 y
:bgcolor unread-message-bg
:fgcolor unread-message-fg
:attributes attributes-to-read)
(print-text object "/" nil nil)
(print-text object
(text-utils:to-s (+ (db:messages-to-read row-fields)
(db:messages-red row-fields)))
nil nil
:bgcolor read-message-bg
:fgcolor read-message-fg))))))
(defmethod resync-rows-db ((object conversations-window) &key
(redraw t)
(suggested-message-index nil))
"Resync this window ehit he conversation in database, if
`suggested-message-index' is not nil masrks as selected the message in
position indicated by this variable."
(with-accessors ((rows rows)
(selected-line-bg selected-line-bg)
(selected-line-fg selected-line-fg)) object
(flet ((make-rows (line-fields bg fg)
(mapcar (lambda (fields)
(let ((name (db:conversation-name fields)))
(make-instance 'line
:fields fields
:normal-text name
:selected-text name
:normal-bg bg
:normal-fg fg
:selected-bg fg
:selected-fg bg)))
line-fields)))
(let ((line-fields (db:all-conversation-stats)))
(with-croatoan-window (croatoan-window object)
(setf rows (make-rows line-fields
selected-line-bg
selected-line-fg))
(when suggested-message-index
(select-row object suggested-message-index))
(when redraw
(draw object)))))))
(defun init ()
"Init the window"
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
(setf *conversations-window*
(make-instance 'conversations-window
:title (_ "Conversations")
:single-row-height 3
:uses-border-p t
:keybindings keybindings:*conversations-keymap*
:croatoan-window low-level-window))
(refresh-config *conversations-window*)
(resync-rows-db *conversations-window* :redraw nil)
(when (rows *conversations-window*)
(select-row *conversations-window* 0))
(draw *conversations-window*)
*conversations-window*))

93
src/crypto-utils.lisp Normal file
View File

@ -0,0 +1,93 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/][http://www.gnu.org/licenses/]].
(in-package :crypto-utils)
(define-constant +crypto-data-prefix+ "CRYPTO:" :test #'string=)
(define-constant +crypto-message-field-separator+ ":" :test #'string=)
(define-constant +crypto-data-prefix-re+ (text-utils:strcat "^" +crypto-data-prefix+)
:test #'string=
:documentation "The encrypted text must starts with this prefix")
(defun crypto-text-p (data)
"Non nil if data starts with `+crypto-data-prefix+'"
(scan +crypto-data-prefix-re+ data))
(defun add-crypto-prefix (data)
(text-utils:strcat +crypto-data-prefix+ data))
(defun strip-crypto-prefix (data)
(misc:safe-subseq data (length +crypto-data-prefix+)))
(defun decode-key (key)
(base64:base64-string-to-usb8-array key))
(defun encode-key (key)
(base64:usb8-array-to-base64-string key))
(defun decode-iv (iv)
(base64:base64-string-to-usb8-array iv))
(defun encode-iv (iv)
(base64:usb8-array-to-base64-string iv))
(defun generate-key (&optional (length 32))
(with-open-file (stream "/dev/urandom" :element-type '(unsigned-byte 8))
(let ((data (misc:make-fresh-array length 0 '(unsigned-byte 8) t)))
(read-sequence data stream)
(encode-key data))))
(defun encrypt (data key)
"Encrypt `data' with `key', note that the initialization vector is autogenerated."
(multiple-value-bind (encrypted-text x y z iv)
(cryptos:encrypt data
(decode-key key)
:mode :cbc
:cipher :aes)
(declare (ignore x y z))
(values encrypted-text
(encode-iv iv))))
(defun decrypt (data key iv)
"Decrypt `data' with `key' and iv (initialization vector)."
(cryptos:decrypt data
(decode-key key)
:iv (decode-iv iv)
:mode :cbc
:cipher :aes))
(defun encrypt-message (data key)
"encrypt a message and wrap it in a valid text to be sent by the
program (add prefix, add iv, separates fields etc.)"
(multiple-value-bind (encrypted-text iv)
(encrypt data key)
(text-utils:strcat +crypto-data-prefix+
iv
+crypto-message-field-separator+
encrypted-text)))
(defun decrypt-message (encrypted-message key)
"Extract iv and actual data from `encrypted-message' and try to
decrypt the latter with key."
(let* ((raw (strip-crypto-prefix encrypted-message))
(iv-mesg (split +crypto-message-field-separator+ raw))
(iv (first iv-mesg))
(encrypted-body (second iv-mesg))
(decrypted (decrypt encrypted-body key iv)))
decrypted))

68
src/date-formatter.lisp Normal file
View File

@ -0,0 +1,68 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2018 cage
;; 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/>.
(in-package :date-formatter)
;; FORMAT := (FIELD | TEXT)*
;; FIELD := [%hour %minute %second %month %year %day %weekday %%]
;; TEXT := (not percent)+
(defrule field
(or "%hour"
"%min"
"%second"
"%month"
"%year"
"%day"
"%weekday"
"%short-weekday"
"%long-weekday"
"%long-month"
"%short-month"
"%%")
(:text t))
(defrule text (+ (not percent))
(:text t))
(defrule format (* (or field text)))
(defun expand-date-formatter-spec (spec)
"Expand a date spec like '%year %short-month %day %hour:%min'
to a list like '(:year :dhort-month :day :hour \":\" (:min 2))
note that:
- %% expands to \"%\"
- %min expands to (:min 2)
- %hour expands to (:hour 2)
- %day expands to (:day 2)
This list can be passed to misc:format-time to get a time string"
(let ((parsed (parse 'format spec)))
(loop for element in parsed collect
(cond
((string= element "%%")
"%")
((string= element "%min")
'(:min 2))
((string= element "%hour")
'(:hour 2))
((string= element "%day")
'(:day 2))
((scan "^%+" element)
(make-keyword (string-upcase (subseq element 1))))
(t
element)))))

445
src/db-utils.lisp Normal file
View File

@ -0,0 +1,445 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/][http://www.gnu.org/licenses/]].
;; derived from:
;; niccolo': a chemicals inventory
;; Copyright (C) 2016 Universita' degli Studi di Palermo
;; 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, 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/>.
(in-package :db-utils)
(define-constant +db-invalid-id-number+ 0 :test #'=)
(define-constant +characters-trouble-name+ '(#\-) :test #'equalp)
(define-constant +separator-re+ "\\." :test #'equalp)
(define-constant +separator+ "." :test #'equalp)
(define-constant +column-wildcard+ "*" :test #'equalp)
(define-constant +directive-no-journaling+ "PRAGMA journal_mode = MEMORY" :test #'string=)
(define-constant +directive-no-sync-os+ "PRAGMA synchronous = OFF" :test #'string=)
(define-constant +directive-foreign-keys+ "PRAGMA foreign_keys = ON" :test #'string=)
(define-constant +directive-foreign-keys-off+ "PRAGMA foreign_keys = OFF" :test #'string=)
(define-constant +sqlite3-db-scheme-table+ :sqlite_master :test #'eq)
(define-constant +sqlite3-db-scheme-table-type+ "table" :test #'string=)
(define-constant +sqlite3-db-scheme-type+ :type :test #'eq)
(define-constant +sqlite3-db-scheme-table-name+ :tbl_name :test #'eq)
(defmacro with-disabled-foreign (&body body)
`(unwind-protect
(progn
(query-low-level +directive-foreign-keys-off+)
,@body)
(query-low-level +directive-foreign-keys+)))
(defparameter *connection* nil)
(defmacro with-db-transaction (&body body)
`(sqlite:with-transaction *connection*
,@body))
(defun connectedp ()
"Non nil if the connection to db is alive"
*connection*)
(defun close-db ()
"Close the connection to database"
(when (connectedp)
(sqlite:disconnect *connection*)))
(defgeneric quote-symbol (s))
(defmethod quote-symbol ((s string))
"Quote `s' to be usable as column name in database (e.g. \"a-b\" -> \\\"a-b\\\")"
(if (scan +separator-re+ s)
(let* ((splitted (split +separator-re+ s))
(res (flatten (loop for i in splitted collect
(if (string= i +column-wildcard+)
i
(format nil "\"~a\"" i))))))
(join-with-strings res +separator+))
(if (null (every #'(lambda (a) (null (find a s)))
+characters-trouble-name+))
(format nil "\"~(~a~)\"" s)
(format nil "~(~a~)" s))))
(defmethod quote-symbol ((s symbol))
(quote-symbol (symbol-name s)))
(defun prepare-query (sql)
"Compile a query in a format suitable to be executed"
#+debug-mode (misc:dbg "compiling ~a~%" sql)
(sqlite:prepare-statement *connection* sql))
(defun execute-query (prepared-sql &optional (parameters nil))
"Execute the prepared query with parameter `parameters'"
(let* ((columns-name (mapcar (lambda (a) (make-keyword (string-upcase a)))
(sqlite:statement-column-names prepared-sql))))
(loop
for param in parameters
for i from 1 do
(sqlite:bind-parameter prepared-sql i param))
(let ((res (loop while (sqlite:step-statement prepared-sql) collect
(loop
for i from 0
for column-name in columns-name
append
(list column-name (sqlite:statement-column-value prepared-sql i))))))
(sqlite:finalize-statement prepared-sql)
res)))
(defun fetch-all (executed-query)
"Fetch all rows from an executed query"
executed-query)
(defun fetch (executed-query)
"Fetch a single row from an executed query"
(first executed-query))
(defun query-low-level (sql &optional (parameters nil))
"prepare and Execute a text in SQL format"
#+debug-mode (misc:dbg "sql ~a parameters ~a~%" sql parameters)
(execute-query (prepare-query sql) parameters))
(defun query (q)
"Execute a sxql query (i.e. sql in s-expression format)"
(multiple-value-bind (sql params)
(sxql:yield q)
(query-low-level sql params)))
(defun query->sql (q)
"Convert sxql to SQL code"
(sxql:yield q))
(defmacro do-rows ((row res) table &body body)
"Iterate each row af a list of lists"
`(let ((,res ,table))
(loop for ,row from 0 below (length ,res) do ,@body)
,res))
(defun prepare-for-sql-like (s)
"Prepare s as an argument for LIKE SQL clause"
(if (not (text-utils:string-empty-p s))
(format nil "%~a%" s)
"%"))
(defmacro object-exists-in-db-p (table clause)
`(fetch (query (select :*
(from ,table)
(where ,clause)))))
(defmacro object-count-in-db (table clause)
`(second (fetch (query (select ((:count :*))
(from ,table)
(where ,clause))))))
(defgeneric db-nil-p (a)
(:documentation "Non nil if the column can be considered a null value in lisp
example:
:nil -> T
\"false\" -> T
0 -> T
\"0\" -> T
\"no\" -> T
\"null\" -> T
"))
(defmethod db-nil-p ((a null))
t)
(defmethod db-nil-p ((a symbol))
(eq a :nil))
(defmethod db-nil-p ((a string))
(or (string-empty-p a)
(string-equal a "false")
(string-equal a "null")
(string-equal a "nil")
(string-equal a "no")
(string-equal a "0")))
(defmethod db-nil-p ((a number))
(num:epsilon= a 0.0))
(defun db-not-nil-p (a)
(not (db-nil-p a)))
(defun db-getf (row indicator &optional (default nil))
"Try to find a value in a `row' (modeled as a plist), return
`default' if indicator has a value of nil in row and signal a
`conditions:column-not-found' if `indicator' does not exists in
`row'."
(let ((res (getf row indicator :not-found)))
(cond
((eq res :not-found)
(error 'conditions:column-not-found :column indicator :row row))
((db-nil-p res)
default)
(t
res))))
(defmacro if-db-nil-else (expr else)
`(if (not (db-nil-p ,expr))
,expr
,else))
(defun count-all (table)
(getf (first (fetch-all (query (select ((:as (:count :*) :ct))
(from table)))))
:ct))
(defun db-path ()
(uiop:unix-namestring (concatenate 'string
(res:home-datadir)
"/"
+db-file+)))
(defun init-connection ()
"Initialize a db connection (and create db file if does not exists)"
(when (not (fs:file-exists-p (db-path)))
(fs:create-file (db-path)))
(setf *connection* (sqlite:connect (db-path))))
(defmacro with-ready-database ((&key (connect t)) &body body)
"Ensure a valid connection to db exists, if `connect' is non
nil (default T), start a new connection"
`(let ((sxql:*sql-symbol-conversion* #'db-utils:quote-symbol))
(when ,connect
(init-connection)
(query-low-level +directive-no-journaling+)
(query-low-level +directive-no-sync-os+)
(query-low-level +directive-foreign-keys+))
(db:maybe-build-all-tables)
(progn ,@body)))
(defun local-time-obj-now ()
(local-time:now))
; db -> application
(defun encode-datetime-string (d &optional (fallback nil))
"Encode a datetime string from db"
(handler-case
(local-time:parse-timestring d)
(error () fallback)))
;; application -> db
(defgeneric decode-datetime-string (object)
(:documentation "Decode object from application to a datetime format
suitable for database."))
(defmethod decode-datetime-string ((object (eql nil)))
"")
(defmethod decode-datetime-string ((object local-time:timestamp))
(local-time:format-rfc3339-timestring nil object))
(defmethod decode-datetime-string ((object string))
(decode-datetime-string (encode-datetime-string object)))
(defmethod decode-datetime-string ((object number))
(decode-datetime-string (universal-to-timestamp object)))
(defgeneric decode-date-string (object)
(:documentation "Decode object from application to a date format
suitable for database."))
(defmethod decode-date-string ((object (eql nil)))
"")
(defmethod decode-date-string ((object local-time:timestamp))
(local-time:format-timestring nil object :format '(:year "-" (:month 2) "-"
(:day 2))))
(defmethod decode-date-string ((object string))
(decode-date-string (encode-datetime-string object)))
(defmethod decode-date-string ((object number))
(decode-date-string (universal-to-timestamp object)))
(defgeneric decode-time-string (object))
(defmethod decode-time-string ((object local-time:timestamp))
(local-time:format-timestring nil object :format '((:hour 2) ":" (:min 2))))
(defmethod decode-time-string ((object string))
(decode-time-string (encode-datetime-string object)))
(defun encoded-datetime-year (decoded)
(misc:extract-year-from-timestamp (encode-datetime-string decoded)))
(defmacro make-insert (table-name names values)
"Generate an sxql insert statement
example
(make-insert :table-name
(:col-a :col-b)
(value-a value-b))
"
(assert (= (length names) (length values)))
`(insert-into ,table-name
(set= ,@(loop
for name in names
for value in values append
(list name value)))))
(defmacro make-delete (table-name where-clause)
"Generate an sxql delete statement
example
(make-delete :table-name
(:col-a :col-b)
(:and (:= col-a 1)
(:= col-b 2)))
"
`(delete-from ,table-name
(where ,where-clause)))
(defmacro make-update (table-name names values where-clause)
"Generate an sxql update statement
example
(make-delete :table-name
(:col-a :col-b)
(1 2)
(:and (:= col-a 1)
(:= col-b 2)))
"
(assert (= (length names) (length values)))
`(update ,table-name
(set= ,@(loop
for name in names
for value in values append
(list name value)))
(where ,where-clause)))
(defun get-max-id (table)
(or (second (fetch (query (select (fields (:max :id)) (from table)))))
0))
(defun get-min-id (table)
(or (second (fetch (query (select (fields (:min :id)) (from table)))))
0))
(defun decode-blob (blob)
(and blob
(base64:usb8-array-to-base64-string blob)))
(defun rows->tsv (rows)
(with-output-to-string (stream)
(labels ((%escape (s)
(regex-replace-all "\"" s "\"\""))
(%fmt (tpl &rest args)
(apply #'format
stream
(strcat tpl (coerce '(#\return #\linefeed) 'string))
args))
(%join (s)
(join-with-strings s (string #\tab)))
(%wrap (s)
(wrap-with (%escape (to-s s)) "\""))
(%filter-print (filter-fn row)
(%join (mapcar #'%wrap
(remove-if-not filter-fn row))))
(%filter-header (a)
(and (symbolp a)
(not (eq :nil a))))
(%filter-data (a)
(cond
((null a)
t)
((and (symbolp a)
(not (eq :nil a)))
nil)
(t t))))
(%fmt (%filter-print #'%filter-header (first-elt rows)))
(loop for row in rows do
(%fmt (%filter-print #'%filter-data row)
:stream stream)))))
(defun table-exists-p (table-name)
(fetch (query (select :*
(from +sqlite3-db-scheme-table+)
(where (:and (:= +sqlite3-db-scheme-table-name+ (quote-symbol table-name))
(:= +sqlite3-db-scheme-type+ +sqlite3-db-scheme-table-type+)))))))
(defgeneric prepare-for-db (object &key &allow-other-keys)
(:documentation "Prepare object to be inserted into database"))
(defmethod prepare-for-db (object &key (to-integer nil) &allow-other-keys)
"Note that object is ignored for unspecialized method"
(if to-integer
1
object))
(defmethod prepare-for-db ((object (eql t)) &key (to-integer nil) &allow-other-keys)
"Note that object is ignored for unspecialized method"
(declare (ignore object))
(if to-integer
1
t))
(defmethod prepare-for-db ((object null)
&key
(to-integer nil)
&allow-other-keys)
(declare (ignorable object))
(if to-integer
0
""))
(defmethod prepare-for-db ((object symbol) &key &allow-other-keys)
(symbol-name object))
(defmethod prepare-for-db ((object string) &key &allow-other-keys)
object)
(defmethod prepare-for-db ((object sequence) &key &allow-other-keys)
(map 'list #'prepare-for-db object))
(defmethod prepare-for-db ((object local-time:timestamp) &key &allow-other-keys)
(decode-datetime-string object))
(defun last-inserted-rowid ()
"Maximum value of a primary key of a table so far"
(sqlite:last-insert-rowid *connection*))

2221
src/db.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

960
src/emoji-shortcodes.lisp Normal file
View File

@ -0,0 +1,960 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/][http://www.gnu.org/licenses/]].
(in-package :emoji-shortcodes)
(defparameter *shortcodes-db*
'((":brown_square:" . "🟫")
(":purple_square:" . "🟪")
(":blue_square:" . "🟦")
(":green_square:" . "🟩")
(":yellow_square:" . "🟨")
(":orange_square:" . "🟧")
(":red_square:" . "🟥")
(":brown_circle:" . "🟤")
(":purple_circle:" . "🟣")
(":green_circle:" . "🟢")
(":yellow_circle:" . "🟡")
(":orange_circle:" . "🟠")
(":razor:" . "🪒")
(":chair:" . "🪑")
(":stethoscope:" . "🩺")
(":bandaid:" . "🩹")
(":blood_drop:" . "🩸")
(":probing_cane:" . "🦯")
(":axe:" . "🪓")
(":diya_lamp:" . "🪔")
(":banjo:" . "🪕")
(":ballet_shoes:" . "🩰")
(":shorts:" . "🩳")
(":briefs:" . "🩲")
(":one_piece_swimsuit:" . "🩱")
(":sari:" . "🥻")
(":safety_vest:" . "🦺")
(":kite:" . "🪁")
(":yoyo:" . "🪀")
(":diving_mask:" . "🤿")
(":ringed_planet:" . "🪐")
(":parachute:" . "🪂")
(":auto_rickshaw:" . "🛺")
(":motor_wheelchair:" . "🦼")
(":wheelchair:" . "🦽")
(":hindu_temple:" . "🛕")
(":ice:" . "🧊")
(":mate:" . "🧉")
(":beverage_box:" . "🧃")
(":oyster:" . "🦪")
(":butter:" . "🧈")
(":falafel:" . "🧆")
(":waffle:" . "🧇")
(":onion:" . "🧅")
(":garlic:" . "🧄")
(":flamingo:" . "🦩")
(":skunk:" . "🦨")
(":otter:" . "🦦")
(":sloth:" . "🦥")
(":guide_dog:" . "🦮")
(":orangutan:" . "🦧")
(":person_kneeling:" . "🧎")
(":person_standing:" . "🧍")
(":person_deaf:" . "🧏")
(":hearing_aid:" . "🦻")
(":mech_leg:" . "🦿")
(":mech_arm:" . "🦾")
(":pinch:" . "🤏")
(":white_heart:" . "🤍")
(":brown_heart:" . "🤎")
(":yawn:" . "🥱")
(":fire_extinguisher:" . "🧯")
(":sponge:" . "🧽")
(":soap:" . "🧼")
(":toilet_paper:" . "🧻")
(":basket:" . "🧺")
(":broom:" . "🧹")
(":safety_pin:" . "🧷")
(":lotion:" . "🧴")
(":dna:" . "🧬")
(":petri_dish:" . "🧫")
(":test_tube:" . "🧪")
(":magnet:" . "🧲")
(":toolbox:" . "🧰")
(":receipt:" . "🧾")
(":abacus:" . "🧮")
(":flat_shoe:" . "🥿")
(":hiking_boot:" . "🥾")
(":lab_coat:" . "🥼")
(":goggles:" . "🥽")
(":yarn:" . "🧶")
(":spool:" . "🧵")
(":teddy_bear:" . "🧸")
(":jigsaw:" . "🧩")
(":nazar_amulet:" . "🧿")
(":lacrosse:" . "🥍")
(":flying_disc:" . "🥏")
(":softball:" . "🥎")
(":red_envelope:" . "🧧")
(":firecracker:" . "🧨")
(":luggage:" . "🧳")
(":skateboard:" . "🛹")
(":brick:" . "🧱")
(":compass:" . "🧭")
(":cupcake:" . "🧁")
(":lobster:" . "🦞")
(":moon_cake:" . "🥮")
(":salt:" . "🧂")
(":bagel:" . "🥯")
(":leafy_green:" . "🥬")
(":mango:" . "🥭")
(":microbe:" . "🦠")
(":mosquito:" . "🦟")
(":parrot:" . "🦜")
(":peacock:" . "🦚")
(":swan:" . "🦢")
(":badger:" . "🦡")
(":kangaroo:" . "🦘")
(":hippo:" . "🦛")
(":llama:" . "🦙")
(":raccoon:" . "🦝")
(":bald:" . "🦲")
(":white_hair:" . "🦳")
(":curly_hair:" . "🦱")
(":red_hair:" . "🦰")
(":villain:" . "🦹")
(":hero:" . "🦸")
(":bone:" . "🦴")
(":tooth:" . "🦷")
(":foot:" . "🦶")
(":leg:" . "🦵")
(":pleading:" . "🥺")
(":partying:" . "🥳")
(":woozy:" . "🥴")
(":freezing:" . "🥶")
(":overheating:" . "🥵")
(":love:" . "🥰")
(":billed_cap:" . "🧢")
(":socks:" . "🧦")
(":coat:" . "🧥")
(":gloves:" . "🧤")
(":scarf:" . "🧣")
(":curling_stone:" . "🥌")
(":sled:" . "🛷")
(":flying_saucer:" . "🛸")
(":chopsticks:" . "🥢")
(":cup_straw:" . "🥤")
(":pie:" . "🥧")
(":takeout_box:" . "🥡")
(":fortune_cookie:" . "🥠")
(":dumpling:" . "🥟")
(":canned_food:" . "🥫")
(":bowl_spoon:" . "🥣")
(":sandwich:" . "🥪")
(":cut_of_meat:" . "🥩")
(":pretzel:" . "🥨")
(":broccoli:" . "🥦")
(":coconut:" . "🥥")
(":cricket:" . "🦗")
(":trex:" . "🦖")
(":sauropod:" . "🦕")
(":hedgehog:" . "🦔")
(":giraffe:" . "🦒")
(":zebra:" . "🦓")
(":person_lotus_position:" . "🧘")
(":person_climbing:" . "🧗")
(":person_steamy_room:" . "🧖")
(":zombie:" . "🧟")
(":genie:" . "🧞")
(":elf:" . "🧝")
(":merperson:" . "🧜")
(":vampire:" . "🧛")
(":fairy:" . "🧚")
(":mage:" . "🧙")
(":breast_feeding:" . "🤱")
(":woman_headscarf:" . "🧕")
(":older_adult:" . "🧓")
(":bearded_person:" . "🧔")
(":adult:" . "🧑")
(":child:" . "🧒")
(":brain:" . "🧠")
(":palms_up:" . "🤲")
(":love_you_gesture:" . "🤟")
(":orange_heart:" . "🧡")
(":censored:" . "🤬")
(":monocle:" . "🧐")
(":shocked:" . "🤯")
(":vomiting:" . "🤮")
(":contempt:" . "🤨")
(":shushing:" . "🤫")
(":gasp:" . "🤭")
(":crazy:" . "🤪")
(":starstruck:" . "🤩")
(":shopping_cart:" . "🛒")
(":drum:" . "🥁")
(":goal:" . "🥅")
(":gi:" . "🥋")
(":boxing_glove:" . "🥊")
(":third_place:" . "🥉")
(":second_place:" . "🥈")
(":first_place:" . "🥇")
(":canoe:" . "🛶")
(":stop_sign:" . "🛑")
(":scooter:" . "🛴")
(":motor_scooter:" . "🛵")
(":spoon:" . "🥄")
(":tumbler_glass:" . "🥃")
(":champagne_glass:" . "🥂")
(":milk:" . "🥛")
(":squid:" . "🦑")
(":shrimp:" . "🦐")
(":salad:" . "🥗")
(":shallow_pan_of_food:" . "🥘")
(":egg:" . "🥚")
(":stuffed_flatbread:" . "🥙")
(":bacon:" . "🥓")
(":pancakes:" . "🥞")
(":french_bread:" . "🥖")
(":croissant:" . "🥐")
(":peanuts:" . "🥜")
(":cucumber:" . "🥒")
(":carrot:" . "🥕")
(":potato:" . "🥔")
(":avocado:" . "🥑")
(":kiwi:" . "🥝")
(":wilted_rose:" . "🥀")
(":butterfly:" . "🦋")
(":shark:" . "🦈")
(":lizard:" . "🦎")
(":owl:" . "🦉")
(":duck:" . "🦆")
(":eagle:" . "🦅")
(":bat:" . "🦇")
(":rhino:" . "🦏")
(":deer:" . "🦌")
(":fox_face:" . "🦊")
(":gorilla:" . "🦍")
(":person_juggling:" . "🤹")
(":person_handball:" . "🤾")
(":person_water_polo:" . "🤽")
(":people_wrestling:" . "🤼")
(":person_cartwheel:" . "🤸")
(":person_fencing:" . "🤺")
(":man_dancing:" . "🕺")
(":mrs_claus:" . "🤶")
(":pregnant_woman:" . "🤰")
(":man_tuxedo:" . "🤵")
(":prince:" . "🤴")
(":person_shrugging:" . "🤷")
(":person_facepalming:" . "🤦")
(":selfie:" . "🤳")
(":handshake:" . "🤝")
(":right_facing_fist:" . "🤜")
(":left_facing_fist:" . "🤛")
(":call_me:" . "🤙")
(":fingers_crossed:" . "🤞")
(":raised_backhand:" . "🤚")
(":black_heart:" . "🖤")
(":clown:" . "🤡")
(":cowboy:" . "🤠")
(":sneezing:" . "🤧")
(":nauseated:" . "🤢")
(":drooling:" . "🤤")
(":lying:" . "🤥")
(":entertained:" . "🤣")
(":black_flag:" . "🏴")
(":crossed_flags:" . "🎌")
(":triangle_flag:" . "🚩")
(":checkered_flag:" . "🏁")
(":black_square_button:" . "🔲")
(":white_square_button:" . "🔳")
(":radio_button:" . "🔘")
(":diamond_dot:" . "💠")
(":down_red_triangle:" . "🔻")
(":up_red_triangle:" . "🔺")
(":small_blue_diamond:" . "🔹")
(":small_orange_diamond:" . "🔸")
(":large_blue_diamond:" . "🔷")
(":large_orange_diamond:" . "🔶")
(":blue_circle:" . "🔵")
(":red_circle:" . "🔴")
(":ja_no_vacancy:" . "🈵")
(":ja_open_for_business:" . "🈺")
(":ja_vacancy:" . "🈳")
(":ja_passing_grade:" . "🈴")
(":ja_application:" . "🈸")
(":ja_acceptable:" . "🉑")
(":ja_prohibited:" . "🈲")
(":ja_discount:" . "🈹")
(":ja_bargain:" . "🉐")
(":ja_not_free_of_carge:" . "🈶")
(":ja_here:" . "🈁")
(":vs:" . "🆚")
(":up:" . "🆙")
(":sos:" . "🆘")
(":ok:" . "🆗")
(":ng:" . "🆖")
(":new:" . "🆕")
(":id:" . "🆔")
(":free:" . "🆓")
(":cool:" . "🆒")
(":cl:" . "🆑")
(":ab_blood:" . "🆎")
(":abc:" . "🔤")
(":symbols:" . "🔣")
(":1234:" . "🔢")
(":abcd:" . "🔡")
(":upper_abcd:" . "🔠")
(":ten:" . "🔟")
(":white_exclamation:" . "❕")
(":white_question:" . "❔")
(":double_curly_loop:" . "➿")
(":curly_loop:" . "➰")
(":division:" . "➗")
(":minus:" . "➖")
(":plus:" . "➕")
(":cross_mark_button:" . "❎")
(":x:" . "❌")
(":white_check_mark:" . "✅")
(":ja_beginner:" . "🔰")
(":name_badge:" . "📛")
(":trident:" . "🔱")
(":mobile_phone_off:" . "📴")
(":vibration_mode:" . "📳")
(":signal_strength:" . "📶")
(":bright:" . "🔆")
(":dim:" . "🔅")
(":cinema:" . "🎦")
(":fast_down_button:" . "⏬")
(":down_button:" . "🔽")
(":fast_up_button:" . "⏫")
(":up_button:" . "🔼")
(":repeat_single:" . "🔂")
(":repeat:" . "🔁")
(":shuffle:" . "🔀")
(":ophiuchus:" . "⛎")
(":six_pointed_star:" . "🔯")
(":menorah:" . "🕎")
(":place_of_worship:" . "🛐")
(":top:" . "🔝")
(":soon:" . "🔜")
(":on:" . "🔛")
(":end:" . "🔚")
(":back:" . "🔙")
(":counter_clockwise:" . "🔄")
(":clockwise:" . "🔃")
(":underage:" . "🔞")
(":no_mobile_phones:" . "📵")
(":no_pedestrians:" . "🚷")
(":non_potable_water:" . "🚱")
(":do_not_litter:" . "🚯")
(":no_bicycles:" . "🚳")
(":no_entry_sign:" . "🚫")
(":children_crossing:" . "🚸")
(":left_luggage:" . "🛅")
(":baggage_claim:" . "🛄")
(":customs:" . "🛃")
(":passport_control:" . "🛂")
(":wc:" . "🚾")
(":restroom:" . "🚻")
(":potable_water:" . "🚰")
(":litter_bin:" . "🚮")
(":atm:" . "🏧")
(":moai:" . "🗿")
(":cigarette:" . "🚬")
(":bathtub:" . "🛁")
(":shower:" . "🚿")
(":toilet:" . "🚽")
(":door:" . "🚪")
(":pill:" . "💊")
(":syringe:" . "💉")
(":satellite_antenna:" . "📡")
(":telescope:" . "🔭")
(":microscope:" . "🔬")
(":link:" . "🔗")
(":nut_and_bolt:" . "🔩")
(":wrench:" . "🔧")
(":bow:" . "🏹")
(":gun:" . "🔫")
(":hammer:" . "🔨")
(":key:" . "🔑")
(":locked_key:" . "🔐")
(":locked_pen:" . "🔏")
(":triangular_ruler:" . "📐")
(":straight_ruler:" . "📏")
(":paperclip:" . "📎")
(":round_pushpin:" . "📍")
(":pushpin:" . "📌")
(":bar_chart:" . "📊")
(":chart_down:" . "📉")
(":chart_up:" . "📈")
(":card_index:" . "📇")
(":torn_calendar:" . "📆")
(":date:" . "📅")
(":open_file_folder:" . "📂")
(":file_folder:" . "📁")
(":briefcase:" . "💼")
(":memo:" . "📝")
(":postbox:" . "📮")
(":envelope_arrow:" . "📩")
(":incoming_envelope:" . "📨")
(":email:" . "📧")
(":dollar_sign:" . "💲")
(":currency_exchange:" . "💱")
(":ja_chart:" . "💹")
(":money_wings:" . "💸")
(":pound:" . "💷")
(":euro:" . "💶")
(":dollar:" . "💵")
(":yen:" . "💴")
(":bookmark:" . "🔖")
(":bookmark_tabs:" . "📑")
(":newspaper:" . "📰")
(":page_facing_up:" . "📄")
(":scroll:" . "📜")
(":page_curl:" . "📃")
(":ledger:" . "📒")
(":notebook:" . "📓")
(":orange_book:" . "📙")
(":blue_book:" . "📘")
(":green_book:" . "📗")
(":book:" . "📖")
(":closed_book:" . "📕")
(":decorative_notebook:" . "📔")
(":red_lantern:" . "🏮")
(":flashlight:" . "🔦")
(":bulb:" . "💡")
(":mag_right:" . "🔎")
(":vhs:" . "📼")
(":camera_flash:" . "📸")
(":movie_camera:" . "🎥")
(":dvd:" . "📀")
(":floppy_disk:" . "💾")
(":minidisc:" . "💽")
(":electric_plug:" . "🔌")
(":battery:" . "🔋")
(":fax:" . "📠")
(":telephone_receiver:" . "📞")
(":mobile_calling:" . "📲")
(":mobile:" . "📱")
(":violin:" . "🎻")
(":trumpet:" . "🎺")
(":musical_keyboard:" . "🎹")
(":guitar:" . "🎸")
(":saxophone:" . "🎷")
(":microphone:" . "🎤")
(":musical_notes:" . "🎶")
(":musical_note:" . "🎵")
(":musical_score:" . "🎼")
(":no_bell:" . "🔕")
(":bell:" . "🔔")
(":postal_horn:" . "📯")
(":megaphone:" . "📣")
(":loudspeaker:" . "📢")
(":loud_sound:" . "🔊")
(":sound:" . "🔉")
(":mute:" . "🔇")
(":gem:" . "💎")
(":ring:" . "💍")
(":lipstick:" . "💄")
(":prayer_beads:" . "📿")
(":top_hat:" . "🎩")
(":womans_hat:" . "👒")
(":crown:" . "👑")
(":womans_boot:" . "👢")
(":womans_sandal:" . "👡")
(":high_heel:" . "👠")
(":sneaker:" . "👟")
(":dress_shoe:" . "👞")
(":backpack:" . "🎒")
(":pouch:" . "👝")
(":handbag:" . "👜")
(":purse:" . "👛")
(":blouse:" . "👚")
(":bikini:" . "👙")
(":kimono:" . "👘")
(":dress:" . "👗")
(":jeans:" . "👖")
(":shirt:" . "👕")
(":necktie:" . "👔")
(":art:" . "🎨")
(":flower_cards:" . "🎴")
(":black_joker:" . "🃏")
(":game_die:" . "🎲")
(":slot_machine:" . "🎰")
(":crystal_ball:" . "🔮")
(":8ball:" . "🎱")
(":dart:" . "🎯")
(":ski:" . "🎿")
(":running_shirt:" . "🎽")
(":fishing_pole:" . "🎣")
(":badminton:" . "🏸")
(":ping_pong:" . "🏓")
(":hockey:" . "🏒")
(":field_hockey:" . "🏑")
(":cricket_game:" . "🏏")
(":bowling:" . "🎳")
(":tennis:" . "🎾")
(":rugby:" . "🏉")
(":football:" . "🏈")
(":volleyball:" . "🏐")
(":basketball:" . "🏀")
(":medal:" . "🏅")
(":ticket:" . "🎫")
(":gift:" . "🎁")
(":ribbon:" . "🎀")
(":moon_ceremony:" . "🎑")
(":wind_chime:" . "🎐")
(":carp_streamer:" . "🎏")
(":dolls:" . "🎎")
(":bamboo:" . "🎍")
(":tanabata_tree:" . "🎋")
(":confetti_ball:" . "🎊")
(":tada:" . "🎉")
(":balloon:" . "🎈")
(":sparkles:" . "✨")
(":sparkler:" . "🎇")
(":fireworks:" . "🎆")
(":christmas_tree:" . "🎄")
(":jack_o_lantern:" . "🎃")
(":ocean:" . "🌊")
(":droplet:" . "💧")
(":fire:" . "🔥")
(":closed_umbrella:" . "🌂")
(":rainbow:" . "🌈")
(":cyclone:" . "🌀")
(":milky_way:" . "🌌")
(":star3:" . "🌠")
(":star2:" . "🌟")
(":sun_face:" . "🌞")
(":full_moon_face:" . "🌝")
(":first_quarter_moon_face:" . "🌛")
(":new_moon_face:" . "🌚")
(":crescent_moon:" . "🌙")
(":waning_crescent_moon:" . "🌘")
(":last_quarter_moon:" . "🌗")
(":waning_gibbous_moon:" . "🌖")
(":waxing_gibbous_moon:" . "🌔")
(":first_quarter_moon:" . "🌓")
(":waxing_crescent_moon:" . "🌒")
(":new_moon:" . "🌑")
(":alarm_clock:" . "⏰")
(":rocket:" . "🚀")
(":aerial_tramway:" . "🚡")
(":mountain_cableway:" . "🚠")
(":suspension_railway:" . "🚟")
(":helicopter:" . "🚁")
(":seat:" . "💺")
(":airplane_arriving:" . "🛬")
(":airplane_departure:" . "🛫")
(":ship:" . "🚢")
(":speedboat:" . "🚤")
(":construction:" . "🚧")
(":vertical_traffic_light:" . "🚦")
(":traffic_light:" . "🚥")
(":rotating_light:" . "🚨")
(":bus_stop:" . "🚏")
(":tractor:" . "🚜")
(":lorry:" . "🚛")
(":truck:" . "🚚")
(":blue_car:" . "🚙")
(":red_car:" . "🚗")
(":oncoming_taxi:" . "🚖")
(":taxi:" . "🚕")
(":police_car:" . "🚓")
(":fire_engine:" . "🚒")
(":minibus:" . "🚐")
(":trolleybus:" . "🚎")
(":bus:" . "🚌")
(":tram_car:" . "🚋")
(":mountain_railway:" . "🚞")
(":monorail:" . "🚝")
(":tram:" . "🚊")
(":station:" . "🚉")
(":light_rail:" . "🚈")
(":train:" . "🚆")
(":bullettrain:" . "🚅")
(":bullettrain_side:" . "🚄")
(":railway_car:" . "🚃")
(":steam_locomotive:" . "🚂")
(":circus_tent:" . "🎪")
(":barber:" . "💈")
(":roller_coaster:" . "🎢")
(":ferris_wheel:" . "🎡")
(":carousel_horse:" . "🎠")
(":bridge_at_night:" . "🌉")
(":sunset:" . "🌇")
(":dusk:" . "🌆")
(":sunrise:" . "🌅")
(":sunrise_over_mountains:" . "🌄")
(":night_stars:" . "🌃")
(":foggy:" . "🌁")
(":kaaba:" . "🕋")
(":synagogue:" . "🕍")
(":mosque:" . "🕌")
(":statue_of_liberty:" . "🗽")
(":tokyo_tower:" . "🗼")
(":wedding:" . "💒")
(":castle:" . "🏰")
(":japanese_castle:" . "🏯")
(":department_store:" . "🏬")
(":school:" . "🏫")
(":convenience_store:" . "🏪")
(":love_hotel:" . "🏩")
(":hotel:" . "🏨")
(":bank:" . "🏦")
(":hospital:" . "🏥")
(":post_office:" . "🏤")
(":ja_post_office:" . "🏣")
(":office:" . "🏢")
(":house_garden:" . "🏡")
(":mount_fuji:" . "🗻")
(":volcano:" . "🌋")
(":japan:" . "🗾")
(":globe:" . "🌐")
(":amphora:" . "🏺")
(":knife:" . "🔪")
(":utensils:" . "🍴")
(":beers:" . "🍻")
(":beer:" . "🍺")
(":tropical_drink:" . "🍹")
(":wine_glass:" . "🍷")
(":champagne:" . "🍾")
(":sake:" . "🍶")
(":tea:" . "🍵")
(":baby_bottle:" . "🍼")
(":honey_pot:" . "🍯")
(":custard:" . "🍮")
(":lollipop:" . "🍭")
(":candy:" . "🍬")
(":chocolate_bar:" . "🍫")
(":cake:" . "🍰")
(":birthday:" . "🎂")
(":cookie:" . "🍪")
(":doughnut:" . "🍩")
(":ice_cream:" . "🍨")
(":shaved_ice:" . "🍧")
(":icecream:" . "🍦")
(":crab:" . "🦀")
(":dango:" . "🍡")
(":fish_cake:" . "🍥")
(":fried_shrimp:" . "🍤")
(":sushi:" . "🍣")
(":oden:" . "🍢")
(":sweet_potato:" . "🍠")
(":spaghetti:" . "🍝")
(":ramen:" . "🍜")
(":curry:" . "🍛")
(":rice:" . "🍚")
(":rice_ball:" . "🍙")
(":rice_cracker:" . "🍘")
(":bento:" . "🍱")
(":popcorn:" . "🍿")
(":stew:" . "🍲")
(":cooking:" . "🍳")
(":burrito:" . "🌯")
(":taco:" . "🌮")
(":hotdog:" . "🌭")
(":pizza:" . "🍕")
(":fries:" . "🍟")
(":hamburger:" . "🍔")
(":poultry_leg:" . "🍗")
(":meat_on_bone:" . "🍖")
(":cheese:" . "🧀")
(":bread:" . "🍞")
(":chestnut:" . "🌰")
(":mushroom:" . "🍄")
(":corn:" . "🌽")
(":eggplant:" . "🍆")
(":tomato:" . "🍅")
(":strawberry:" . "🍓")
(":cherries:" . "🍒")
(":peach:" . "🍑")
(":pear:" . "🍐")
(":green_apple:" . "🍏")
(":apple:" . "🍎")
(":pineapple:" . "🍍")
(":banana:" . "🍌")
(":lemon:" . "🍋")
(":tangerine:" . "🍊")
(":watermelon:" . "🍉")
(":melon:" . "🍈")
(":grapes:" . "🍇")
(":leaves:" . "🍃")
(":fallen_leaf:" . "🍂")
(":maple_leaf:" . "🍁")
(":four_leaf_clover:" . "🍀")
(":herb:" . "🌿")
(":ear_of_rice:" . "🌾")
(":cactus:" . "🌵")
(":palm_tree:" . "🌴")
(":deciduous_tree:" . "🌳")
(":evergreen_tree:" . "🌲")
(":seedling:" . "🌱")
(":tulip:" . "🌷")
(":blossom:" . "🌼")
(":sunflower:" . "🌻")
(":hibiscus:" . "🌺")
(":rose:" . "🌹")
(":white_flower:" . "💮")
(":cherry_blossom:" . "🌸")
(":bouquet:" . "💐")
(":scorpion:" . "🦂")
(":beetle:" . "🐞")
(":bee:" . "🐝")
(":ant:" . "🐜")
(":bug:" . "🐛")
(":snail:" . "🐌")
(":shell:" . "🐚")
(":octopus:" . "🐙")
(":blowfish:" . "🐡")
(":tropical_fish:" . "🐠")
(":dolphin:" . "🐬")
(":whale:" . "🐋")
(":spouting_whale:" . "🐳")
(":dragon:" . "🐉")
(":dragon_face:" . "🐲")
(":snake:" . "🐍")
(":turtle:" . "🐢")
(":crocodile:" . "🐊")
(":frog_face:" . "🐸")
(":penguin:" . "🐧")
(":hatched_chick:" . "🐥")
(":baby_chick:" . "🐤")
(":hatching_chick:" . "🐣")
(":rooster:" . "🐓")
(":chicken:" . "🐔")
(":turkey:" . "🦃")
(":feet:" . "🐾")
(":panda_face:" . "🐼")
(":koala_face:" . "🐨")
(":bear_face:" . "🐻")
(":rabbit:" . "🐇")
(":rabbit_face:" . "🐰")
(":hamster_face:" . "🐹")
(":rat:" . "🐀")
(":mouse:" . "🐁")
(":mouse_face:" . "🐭")
(":elephant:" . "🐘")
(":two_hump_camel:" . "🐫")
(":camel:" . "🐪")
(":goat:" . "🐐")
(":sheep:" . "🐑")
(":ram:" . "🐏")
(":pig_nose:" . "🐽")
(":boar:" . "🐗")
(":pig:" . "🐖")
(":pig_face:" . "🐷")
(":cow:" . "🐄")
(":water_buffalo:" . "🐃")
(":ox:" . "🐂")
(":cow_face:" . "🐮")
(":unicorn_face:" . "🦄")
(":horse:" . "🐎")
(":horse_face:" . "🐴")
(":leopard:" . "🐆")
(":tiger:" . "🐅")
(":tiger_face:" . "🐯")
(":lion_face:" . "🦁")
(":cat_face:" . "🐱")
(":wolf_face:" . "🐺")
(":poodle:" . "🐩")
(":dog_face:" . "🐶")
(":monkey:" . "🐒")
(":monkey_face:" . "🐵")
(":tone_dark:" . "🏿")
(":tone_medium_dark:" . "🏾")
(":tone_medium:" . "🏽")
(":tone_medium_light:" . "🏼")
(":tone_light:" . "🏻")
(":footprints:" . "👣")
(":busts_silhouette:" . "👥")
(":bust_silhouette:" . "👤")
(":couple_heart:" . "💑")
(":couple:" . "💏")
(":holding_hands_mm:" . "👬")
(":holding_hands_mw:" . "👫")
(":holding_hands_ww:" . "👭")
(":in_bed:" . "🛌")
(":bath:" . "🛀")
(":person_mountain_biking:" . "🚵")
(":person_biking:" . "🚴")
(":person_rowing_boat:" . "🚣")
(":horse_racing:" . "🏇")
(":people_bunny_ears_partying:" . "👯")
(":dancer:" . "💃")
(":person_running:" . "🏃")
(":person_walking:" . "🚶")
(":person_getting_haircut:" . "💇")
(":person_getting_massage:" . "💆")
(":santa:" . "🎅")
(":baby_angel:" . "👼")
(":bride_veil:" . "👰")
(":man_chinese_cap:" . "👲")
(":person_turban:" . "👳")
(":princess:" . "👸")
(":construction_worker:" . "👷")
(":guard:" . "💂")
(":police_officer:" . "👮")
(":person_bowing:" . "🙇")
(":person_raising_hand:" . "🙋")
(":person_tipping_hand:" . "💁")
(":person_gesturing_ok:" . "🙆")
(":person_gesturing_no:" . "🙅")
(":person_pouting:" . "🙎")
(":person_frowning:" . "🙍")
(":older_woman:" . "👵")
(":older_man:" . "👴")
(":woman:" . "👩")
(":man:" . "👨")
(":blond_person:" . "👱")
(":girl:" . "👧")
(":boy:" . "👦")
(":baby:" . "👶")
(":lips:" . "👄")
(":tongue:" . "👅")
(":eyes:" . "👀")
(":nose:" . "👃")
(":muscle:" . "💪")
(":nail_care:" . "💅")
(":pray:" . "🙏")
(":open_hands:" . "👐")
(":raised_hands:" . "🙌")
(":clap:" . "👏")
(":punch:" . "👊")
(":fist:" . "✊")
(":middle_finger:" . "🖕")
(":metal:" . "🤘")
(":ok_hand:" . "👌")
(":vulcan:" . "🖖")
(":raised_hand:" . "✋")
(":wave:" . "👋")
(":zzz:" . "💤")
(":thought:" . "💭")
(":speech:" . "💬")
(":dash:" . "💨")
(":sweat_drops:" . "💦")
(":dizzy_star:" . "💫")
(":boom:" . "💥")
(":anger:" . "💢")
(":100:" . "💯")
(":purple_heart:" . "💜")
(":blue_heart:" . "💙")
(":green_heart:" . "💚")
(":yellow_heart:" . "💛")
(":broken_heart:" . "💔")
(":heart_decoration:" . "💟")
(":two_hearts:" . "💕")
(":revolving_hearts:" . "💞")
(":heartbeat:" . "💓")
(":heartpulse:" . "💗")
(":sparkling_heart:" . "💖")
(":heart_ribbon:" . "💝")
(":cupid:" . "💘")
(":love_letter:" . "💌")
(":kiss_lips:" . "💋")
(":speak_no_evil:" . "🙊")
(":hear_no_evil:" . "🙉")
(":see_no_evil:" . "🙈")
(":pouting_cat:" . "😾")
(":crying_cat:" . "😿")
(":weary_cat:" . "🙀")
(":kissing_cat:" . "😽")
(":smirking_cat:" . "😼")
(":lovestruck_cat:" . "😻")
(":joyful_cat:" . "😹")
(":grinning_cat:" . "😸")
(":smiling_cat:" . "😺")
(":robot:" . "🤖")
(":alien_monster:" . "👾")
(":ghost:" . "👻")
(":goblin:" . "👺")
(":ogre:" . "👹")
(":poop:" . "💩")
(":skull:" . "💀")
(":angry_imp:" . "👿")
(":imp:" . "😈")
(":angry:" . "😠")
(":enraged:" . "😡")
(":annoyed:" . "😤")
(":tired:" . "😫")
(":weary:" . "😩")
(":shamed:" . "😓")
(":disappointed:" . "😞")
(":persevered:" . "😣")
(":confounded:" . "😖")
(":frightened:" . "😱")
(":distressed:" . "😭")
(":upset:" . "😢")
(":hopeful:" . "😥")
(":cold_sweat:" . "😰")
(":fearful:" . "😨")
(":anguished:" . "😧")
(":bored:" . "😦")
(":flushed:" . "😳")
(":astonished:" . "😲")
(":hushed:" . "😯")
(":surprised:" . "😮")
(":cheerless:" . "🙁")
(":worried:" . "😟")
(":confused:" . "😕")
(":nerd:" . "🤓")
(":confident:" . "😎")
(":dizzy:" . "😵")
(":injured:" . "🤕")
(":sick:" . "🤒")
(":ill:" . "😷")
(":exhausted:" . "😴")
(":sleepy:" . "😪")
(":pensive:" . "😔")
(":relieved:" . "😌")
(":grimaced:" . "😬")
(":disbelief:" . "🙄")
(":unamused:" . "😒")
(":cocky:" . "😏")
(":vacant:" . "😶")
(":apathetic:" . "😑")
(":silenced:" . "🤐")
(":curious:" . "🤔")
(":hugging:" . "🤗")
(":pretentious:" . "🤑")
(":facetious:" . "😝")
(":mischievous:" . "😜")
(":playful:" . "😛")
(":yum:" . "😋")
(":happy_kiss:" . "😙")
(":loving_kiss:" . "😚")
(":kiss:" . "😗")
(":flirty:" . "😘")
(":lovestruck:" . "😍")
(":innocent:" . "😇")
(":blush:" . "😊")
(":coy:" . "😉")
(":ecstatic:" . "🙃")
(":pleased:" . "🙂")
(":joyful:" . "😂")
(":embarassed:" . "😅")
(":amused:" . "😆")
(":blissful:" . "😁")
(":happy:" . "😄")
(":glad:" . "😃")
(":gleeful:" . "😀")))
(defun shortcode-lookup (key)
(assoc key *shortcodes-db* :test #'string-equal))
(defun emojify (text)
(loop for mapping in *shortcodes-db* do
(setf text (cl-ppcre:regex-replace-all (car mapping) text (cdr mapping))))
text)

368
src/filesystem-utils.lisp Normal file
View File

@ -0,0 +1,368 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :filesystem-utils)
(define-constant +preprocess-include+ "^%include" :test #'string=)
(define-constant +file-path-regex+ "[\\p{L},\\/,\\\\,\\.]+" :test 'string=)
(defparameter *directory-sep-regexp*
#+windows "\\"
#-windows "\\/")
(defparameter *directory-sep*
#+windows "\\"
#-windows "/")
(defun copy-a-file (in out &key (overwrite nil))
(if (and in
(file-exists-p in)
out
(or (not (file-exists-p out))
overwrite))
(progn
(uiop:copy-file in out)
out)
nil))
(defun file-size (filename)
(with-open-file (stream filename :direction :input :element-type '(unsigned-byte 8)
:if-does-not-exist nil)
(if (null stream)
0
(file-length stream))))
(defun slurp-file (filename &key (convert-to-string t))
"A simple way to slurp a file."
(with-open-file (stream filename :direction :input :element-type '(unsigned-byte 8))
(let ((seq (make-array (file-length stream) :element-type '(unsigned-byte 8))))
(read-sequence seq stream)
(if convert-to-string
(babel:octets-to-string seq)
seq))))
(defun dump-sequence-to-file (seq file)
(with-open-file (stream file
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(write-sequence seq stream)))
(defun create-file (file &key (skip-if-exists nil))
"create file and parent dir, if necessary"
(when (not (and skip-if-exists
(file-exists-p file)))
(let ((path-splitted (fs:split-path-elements file)))
(when (and path-splitted
(> (length path-splitted) 1))
(do* ((path-rest (subseq path-splitted 0
(1- (length path-splitted)))
(rest path-rest))
(path-so-far "" (if (and path-rest
(not (string= "" (first-elt path-rest))))
(concatenate 'string
path-so-far
*directory-sep*
(first-elt path-rest)
*directory-sep*)
path-so-far)))
((null path-rest))
(when (not (directory-exists-p path-so-far))
(make-directory path-so-far)))
(with-open-file (stream file
:direction :output
:if-exists :supersede
:if-does-not-exist :create))))))
(defun has-extension (path ext)
(let ((re (concatenate 'string ext "$")))
(cl-ppcre:scan re path)))
(defun strip-extension (file &key (strip-all nil))
(let ((new (cl-ppcre:regex-replace "(?i)[a-z0-9]\\.[^.]+$" file "")))
(if (string= file new)
new
(if strip-all
(strip-extension new :strip-all t)
new))))
(defun get-extension (file)
(multiple-value-bind (matchedp res)
(cl-ppcre:scan-to-strings "(?i)[a-z0-9]\(\\.[^.]+$\)" file)
(when matchedp
(first-elt res))))
(defun add-extension (file extension)
(text-utils:strcat file "." extension))
(defun cat-parent-dir (parent direntry)
(format nil "~a~a~a" parent *directory-sep* direntry))
(defmacro do-directory ((var) root &body body)
(with-gensyms (dir)
`(let ((,dir (nix:opendir ,root)))
(unwind-protect
(handler-case
(do ((,var (cat-parent-dir ,root (nix:readdir ,dir))
(cat-parent-dir ,root (nix:readdir ,dir))))
((cl-ppcre:scan "NIL$" ,var))
,@body)
(nix::enotdir () 0)
(nix:eacces () 0)
(nix:eloop () 0))
(nix:closedir ,dir)))))
(defun search-matching-file (root-directory &key (name ".*"))
"Scan a filesystem saving files that match the provided criteria,
does not follow symlinks."
(let ((matched '())
(scanner (cl-ppcre:create-scanner name)))
(labels ((match (dir)
(do-directory (path) dir
(let ((filename (path-last-element path)))
(cond
((regular-file-p path)
(when (cl-ppcre:scan scanner filename)
(push path matched)))
((and (not (cl-ppcre:scan "^\\.\\." filename))
(not (cl-ppcre:scan "^\\." filename))
(dirp path))
(match path)))))))
(match root-directory)
matched)))
(defun regular-file-p (path)
(nix:s-isreg (nix:stat-mode (nix:stat path))))
(defun dirp (path)
(nix:s-isdir (nix:stat-mode (nix:stat path))))
(defun split-path-elements (path)
(cl-ppcre:split *directory-sep-regexp* path))
(defun path-last-element (path)
(let ((elements (cl-ppcre:split *directory-sep-regexp* path)))
(and elements
(last-elt elements))))
(defun path-first-element (path)
(let ((elements (cl-ppcre:split *directory-sep-regexp* path)))
(and elements
(first-elt elements))))
(defun path-to-hidden-file-p (path)
"unix-like only"
(let ((last-element (path-last-element path)))
(and path (cl-ppcre:scan "^\\." last-element))))
(defun strip-dirs-from-path (p)
(multiple-value-bind (all registers)
(cl-ppcre:scan-to-strings (concatenate 'string
*directory-sep*
"([^"
*directory-sep*
"]+)$")
p)
(declare (ignore all))
(and (> (length registers) 0)
(elt registers 0))))
(defun parent-dir-path (path)
(let ((splitted (remove-if #'(lambda (a) (string= "" a))
(split-path-elements path))))
(cond
((> (length splitted) 1)
(let ((res (if (string= (string (elt path 0)) *directory-sep*)
(concatenate 'string *directory-sep* (first splitted))
(first splitted))))
(loop for i in (subseq splitted 1 (1- (length splitted))) do
(setf res (concatenate 'string res *directory-sep* i)))
(setf res (concatenate 'string res *directory-sep*))
res))
((null splitted)
*directory-sep*)
(t
path))))
(defmacro define-stat-time (slot-name)
(with-gensyms (stat)
`(defun ,(format-symbol t "~:@(get-stat-~a~)" slot-name) (file)
(restart-case
(let ((,stat (nix:stat file)))
(when ,stat
(misc:time-unix->universal (,(format-symbol :nix "~:@(stat-~a~)" slot-name)
,stat))))
(use-value (value) value)))))
(define-stat-time mtime)
(define-stat-time ctime)
(define-stat-time atime)
(defun file-hash (file)
(num:fnv-hash-32 (slurp-file file :convert-to-string nil)))
(defun file-outdated-p (file &rest dependencies)
(handler-bind ((nix:enoent #'(lambda (c)
(declare (ignore c))
(invoke-restart 'use-value nil))))
(let ((mtime-file (get-stat-mtime file))
(mtimes-deps (remove-if #'null (mapcar #'get-stat-mtime dependencies))))
(if mtime-file
(remove-if #'(lambda (mtime) (<= mtime mtime-file)) mtimes-deps)
t))))
(defun file-exists-p (f)
(uiop:file-exists-p f))
(defun directory-exists-p (d)
(uiop:directory-exists-p d))
(defun delete-file-if-exists (f)
(uiop:delete-file-if-exists f))
(defun file-length-if-exists (f)
(when (file-exists-p f)
(with-open-file (stream f :element-type '(unsigned-byte 8))
(file-length stream))))
(defun home-dir (&key (add-separator-ends nil))
(let ((home (os-utils:getenv "HOME")))
(if add-separator-ends
(text-utils:strcat home *directory-sep*)
home)))
(defun temporary-filename (&optional (temp-directory nil))
(let ((tmpdir (or temp-directory
(os-utils:default-temp-dir))))
(multiple-value-bind (x filename)
(if tmpdir
(nix:mkstemp (format nil "~a~a~a" tmpdir *directory-sep*
config:+program-name+))
(nix:mkstemp (format nil "~atmp~a~a" *directory-sep* *directory-sep*
config:+program-name+)))
(declare (ignore x))
filename)))
(defmacro with-anaphoric-temp-file ((stream &key (prefix nil) (unlink nil)) &body body)
`(let ((temp-file (temporary-filename ,prefix))) ; anaphora
(unwind-protect
(with-open-file (,stream temp-file
:direction :output
:if-exists :error
:if-does-not-exist :create)
,@body)
,(if unlink
`(delete-file-if-exists temp-file)
nil))))
(defun has-file-permission-p (file permission)
(find permission (osicat:file-permissions file) :test #'eq))
(defun file-can-write-p (file)
(has-file-permission-p file :user-write))
(defmacro gen-permission-files (&rest modes)
`(progn
,@(loop for mode in modes collect
`(define-constant ,(misc:format-fn-symbol t "+~a+" mode)
,mode
:test #'eql))))
(gen-permission-files
nix:s-irwxu nix:s-irusr nix:s-iwusr nix:s-ixusr nix:s-irwxg nix:s-irgrp nix:s-iwgrp
nix:s-ixgrp nix:s-irwxo nix:s-iroth nix:s-iwoth nix:s-ixoth nix:s-isuid nix:s-isgid)
(defun set-file-permissions (file mode)
(nix:chmod file mode))
(misc:defcached cached-directory-files ((path) :test equal)
(declare (optimize (speed 0) (safety 3) (debug 3)))
(if (gethash path cache)
(gethash path cache)
(progn
(setf (gethash path cache) (uiop:directory-files path))
(cached-directory-files path))))
(defun directory-files (path)
(and path
(uiop:directory-files path)))
(defun make-directory (path)
(if (not (cl-ppcre:scan (concatenate 'string *directory-sep* "$") path))
(make-directory (concatenate 'string path *directory-sep*))
(ensure-directories-exist path)))
(defun package-path ()
(uiop:pathname-parent-directory-pathname
(asdf:component-pathname
(asdf:find-component (symbolicate (string-upcase config:+program-name+))
nil))))
(defun file-in-package (name)
(concatenate 'string (namestring (package-path)) name))
(defparameter *file-link-to* nil)
(define-constant +rel-link+ :rel)
(define-constant +abs-link+ :abs)
(defmacro see-file (&body forms)
(if (> (length forms) 1)
(warn "see-file: too many elements in forms, must be exactly 2"))
(let ((path (first-elt forms)))
(when (not (stringp path))
(error (format nil "see-file: the path ~a is not a string" path)))
(when (= (length path) 0)
(error (format nil "see-file: the path ~a is to short" path)))
(if (string= *directory-sep* (string (first-elt path)))
`(setf *file-link-to* (cons ,path +abs-link+))
`(setf *file-link-to* (cons ,path +rel-link+)))))
(defun link-file-path (file)
(misc:with-load-forms-in-var (*file-link-to* link-file file)
(if link-file
(destructuring-bind (path . type)
link-file
(if (eq type +rel-link+)
(cat-parent-dir (parent-dir-path file) path)
path))
nil)))
(defmacro file-is-link-if-else ((file link-file-pointed) is-link-forms is-not-link-forms)
`(let ((,link-file-pointed (link-file-path ,file)))
(if ,link-file-pointed
,is-link-forms
,is-not-link-forms)))
(defun pathname->namestring (p)
(uiop:native-namestring p))
(defun namestring->pathname (p)
(uiop:parse-native-namestring p))
(defun read-single-form (file)
(with-open-file (stream file :direction :input :if-does-not-exist nil)
(when stream
(read stream))))
(defun eq-filename (a b)
(flet ((strip (a) (strip-dirs-from-path (pathname->namestring a))))
(string= (strip a)
(strip b))))

149
src/follow-requests.lisp Normal file
View File

@ -0,0 +1,149 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :follow-requests)
(defclass follow-requests-window (focus-marked-window simple-line-navigation-window)
((requests
:initarg :requests
:initform ()
:accessor requests
:type tooter:account
:documentation "All the accounts that request to follow you")
(header-message-lines
:initarg :header-message-lines
:initform ()
:accessor header-message-lines
:documentation "lines of text printed on top of the window")
(screen
:initarg :screen
:initform nil
:accessor screen
:documentation "A reference to the main window (the screen)")
(style
:initarg :style
:initform nil
:accessor style
:documentation "The visual style of the window")))
(defmethod refresh-config :after ((object follow-requests-window))
(with-accessors ((screen screen)
(croatoan-window croatoan-window)
(bgcolor bgcolor)
(fgcolor fgcolor)
(top-row-padding top-row-padding)
(header-message-lines header-message-lines)
(style style)) object
(let* ((theme-style (swconf:form-style swconf:+key-input-dialog+))
(fg (swconf:foreground theme-style))
(bg (swconf:background theme-style))
(width (truncate (/ (win-width screen)
3)))
(height (truncate (/ (win-height screen)
3)))
(y (truncate (- (/ (win-height screen) 2)
(/ height 2))))
(x (truncate (- (/ (win-width screen) 2)
(/ width 2)))))
(setf (background croatoan-window)
(tui:make-background bg))
(setf (bgcolor croatoan-window) bg)
(setf (fgcolor croatoan-window) fg)
(setf style theme-style)
(win-resize object width height)
(win-move object x y)
(let* ((header (_ "Please evaluate the following requests, only items shown below will be accepted, deleted ones will be rejected:"))
(header-words (text-utils:split-words header))
(header-lines (text-utils:flush-left-mono-text header-words
(win-width-no-border object)))
(attach-y-start (1+ (length header-lines))))
(setf top-row-padding attach-y-start)
(setf header-message-lines header-lines))
object)))
(defmethod draw :after ((object follow-requests-window))
(with-accessors ((style style)
(header-message-lines header-message-lines)) object
(with-croatoan-window (croatoan-window object)
(let* ((bgcolor (bgcolor croatoan-window))
(fgcolor (fgcolor croatoan-window))
(win-width (win-width-no-border object)))
(loop
for y from 1
for line in header-message-lines do
(print-text object
(text-utils:right-padding line win-width)
1 y
:fgcolor fgcolor
:bgcolor bgcolor
:attributes (attribute-bold)))))))
(defun init (follow-requests usernames-follow-requests screen)
"Initialize the window
- follows-requests the account entity (from tooter library) that requestes to follow you
- username-follow-requests the username of the accounts that requestes to follow you
- screen the main window
"
(flet ((make-rows (usernames bg fg)
(mapcar (lambda (username)
(make-instance 'line
:normal-text username
:selected-text username
:normal-bg bg
:normal-fg fg
:selected-bg fg
:selected-fg bg))
usernames)))
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
(setf *follow-requests-window*
(make-instance 'follow-requests-window
:requests follow-requests
:uses-border-p t
:screen screen
:keybindings keybindings:*follow-requests-keymap*
:croatoan-window low-level-window))
(refresh-config *follow-requests-window*)
(setf (rows *follow-requests-window*)
(make-rows usernames-follow-requests
(bgcolor low-level-window)
(fgcolor low-level-window)))
(setf (row-selected-index *follow-requests-window*) 0)
*follow-requests-window*)))
(defun process-requests ()
"Process the accepted or follow' requests, the accepted are the
requeste that are not be erased from the window (see the class
row-oriented-widget)"
(with-accessors ((all-accounts requests)
(rows rows)) specials:*follow-requests-window*
(let* ((accepted-usernames (mapcar #'normal-text rows))
(accepted-accounts (remove-if-not (lambda (acc)
(find-if (lambda (a)
(string= a
(tooter:account-name acc)))
accepted-usernames))
all-accounts))
(rejected-accounts (set-difference all-accounts
accepted-accounts
:key #'tooter:id
:test #'string=)))
(loop for accepted-account in accepted-accounts do
(let ((id (tooter:id accepted-account)))
(api-client:accept-follow-request id)))
(loop for rejected-account in rejected-accounts do
(let ((id (tooter:id rejected-account)))
(api-client:reject-follow-request id))))))

83
src/hooks.lisp Normal file
View File

@ -0,0 +1,83 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :hooks)
(defvar *hook* nil
"The hook currently being run.")
(defgeneric add-hook (hook fn &key append)
(:documentation "Add FN to the value of HOOK.")
(:method ((hook symbol) fn &key append)
(declare (type (or function symbol) fn))
(if (not append)
(pushnew fn (symbol-value hook))
(unless (member fn (symbol-value hook))
(appendf (symbol-value hook) (list fn))))))
(defgeneric remove-hook (hook fn)
(:documentation "Remove FN from the symbol value of HOOK.")
(:method ((hook symbol) fn)
(removef (symbol-value hook) fn)))
(defmacro with-hook-restart (&body body)
`(with-simple-restart (continue "Call next function in hook ~s" *hook*)
,@body))
(defun run-hooks (&rest hooks)
"Run all the hooks in HOOKS, without arguments.
The variable `*hook*' is bound to the name of each hook as it is being
run."
(dolist (*hook* hooks)
(run-hook *hook*)))
(defgeneric run-hook (hook &rest args)
(:documentation "Apply each function in HOOK to ARGS.")
(:method ((*hook* symbol) &rest args)
(dolist (fn (symbol-value *hook*))
(with-hook-restart
(apply fn args)))))
(defgeneric run-hook-until-failure (hook &rest args)
(:documentation "Like `run-hook-with-args', but quit once a function returns nil.")
(:method ((*hook* symbol) &rest args)
(loop
for fn in (symbol-value *hook*)
always (apply fn args))))
(defgeneric run-hook-until-success (hook &rest args)
(:documentation "Like `run-hook-with-args', but quit once a function returns
non-nil.")
(:method ((*hook* symbol) &rest args)
(loop
for fn in (symbol-value *hook*)
thereis (apply fn args))))
(defparameter *before-main-loop* ()
"run this hooks before UI main loop starts")
(defparameter *before-quit* ()
"Run this hooks just before closing the database connection and the
program")
(defparameter *before-prepare-for-rendering-message* '()
"Run this hooks before rendering the message on a
message-window (the message window is passed as parameter")
(defparameter *before-sending-message* '()
"Run this hooks before sending the message, note that the message
could be encrypted after this hooks runs, the function takes a
message-window as parameter")

145
src/html-utils.lisp Normal file
View File

@ -0,0 +1,145 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/][http://www.gnu.org/licenses/]].
(in-package :html-utils)
(define-constant +tag-link+ "a" :test #'string=)
(define-constant +tag-break+ "br" :test #'string=)
(define-constant +tag-paragraph+ "p" :test #'string=)
(define-constant +tag-div+ "div" :test #'string=)
(define-constant +attribute-url+ "href" :test #'string=)
(defun tag (node)
"Given a node returns the tag part"
(first node))
(defun attributes (node)
"Given a node returns the attribute part"
(second node))
(defun attribute-key (attribute)
"Given an attribute the key part"
(first attribute))
(defun attribute-value (attribute)
"Given an attribute the value part"
(second attribute))
(defun children (node)
"Return children of this nodes if exists"
(when (and node
(listp node)
(> (length node)
2))
(subseq node 2)))
(defun tag= (tag node)
(string-equal tag (tag node)))
(defun find-attribute (attribute-key node)
"find attribute on a node"
(find-if (lambda (attribute)
(string= attribute-key
(attribute-key attribute)))
(attributes node)))
(defun html->text (html &key (add-link-footnotes t))
"Transform html to text, note that if `add-link-footnotes` is non nil footnotes that marks html link in the text are added aftere the body of the message
This function uses a library that transhorm html5 text into s-expressions um the form
'(name (attributes) children*)
Some convenience functions are provided to works with this structures.
"
(when html
(let ((root (append (list :root
nil)
(html5-parser:parse-html5-fragment html :dom :xmls)))
(link-count 0)
(body (misc:make-fresh-array 0 #\a 'character nil))
(footnotes (misc:make-fresh-array 0 #\a 'character nil)))
(with-output-to-string (body-stream body)
(with-output-to-string (footnotes-stream footnotes)
(format footnotes-stream "~2%")
(labels ((descend-children (node)
(loop for child in (children node) do
(descend child)))
(descend (node)
(when node
(cond
((stringp node)
(princ node body-stream))
((consp (car node))
(descend (car node)))
((tag= +tag-link+ node)
(let ((link (find-attribute +attribute-url+ node)))
(incf link-count)
(if link
(format footnotes-stream
"[~a] ~a~%"
link-count
(attribute-value link))
(format footnotes-stream
"[~a] ~a~%"
link-count
(_ "No address found")))
(descend-children node)
(when add-link-footnotes
(format body-stream "[~a] " link-count))))
((tag= +tag-break+ node)
(format body-stream "~%")
(descend-children node))
((or (tag= +tag-paragraph+ node)
(tag= +tag-div+ node))
(format body-stream "~%")
(descend-children node)
(format body-stream "~%"))
(t
(descend-children node))))))
(descend root)
(if add-link-footnotes
(strcat body footnotes)
body)))))))
(defun extract-shotcodes (file)
"Extract shotcodes from the file:
https://github.com/milesj/emojibase/blob/master/packages/generator/src/resources/shortcodes.ts.
Returns an alist (cons shortcode utf8-emoj)"
(with-open-file (stream file)
(flet ((readline ()
(read-line stream nil nil)))
(let ((res ()))
(loop with i = (readline) while i do
(multiple-value-bind (match-emoji-p registers-emoji)
(cl-ppcre:scan-to-strings "^\\s+// \(.\) " i)
(when match-emoji-p
(let ((emoji (first-elt registers-emoji)))
(setf i (readline))
(multiple-value-bind (match-shortcode-p registers-shortcode)
(cl-ppcre:scan-to-strings "\\['\([^']+\)'\(\\]|,\)" i)
(when match-shortcode-p
(setf res
(acons (format nil ":~a:" (first-elt registers-shortcode))
(format nil "~a" emoji)
res)))))))
(setf i (readline)))
res))))

70
src/interfaces.lisp Normal file
View File

@ -0,0 +1,70 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :interfaces)
(defgeneric clone (object))
(defmethod clone (object))
(defgeneric clone-into (from to))
(defmethod clone-into (from to))
(defgeneric copy-flat (object))
(defmethod copy-flat (object))
(defgeneric copy-flat-into (from to))
(defmethod copy-flat-into (from to))
(defmacro with-simple-clone ((object type))
(alexandria:with-gensyms (res)
`(let ((,res (make-instance ,type)))
(clone-into ,object ,res)
,res)))
(defmacro with-simple-copy-flat ((object type))
(alexandria:with-gensyms (res)
`(let ((,res (make-instance ,type)))
(copy-flat-into ,object ,res)
,res)))
(defgeneric serialize (object))
(defgeneric serialize-to-stream (object stream))
(defgeneric deserialize (object file))
(defmethod serialize (object)
(format nil "~s" (marshal:marshal object)))
(defmethod serialize-to-stream (object stream)
(prin1 (marshal:marshal object) stream))
(defmethod deserialize (object file)
(declare (ignore object))
(marshal:unmarshal (read-from-string (filesystem-utils:slurp-file file))))
;; to use with ms:initialize-unmarshalled-instance
(defgeneric post-deserialization-fix (object))
(defmethod post-deserialization-fix (object)
object)
(defmethod post-deserialization-fix ((object (eql nil)))
nil)

146
src/keybindings-window.lisp Normal file
View File

@ -0,0 +1,146 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :keybindings-window)
(defclass keybindings-window (suggestions-window tree-holder)
((keybindings-tree
:initform nil
:initarg :keybindings-tree
:accessor keybindings-tree
:documentation "The keymap"))
(:documentation "A window that suggests next keys in a keymap"))
(defmethod refresh-config :after ((object keybindings-window))
(with-croatoan-window (croatoan-window object)
(refresh-config-colors object swconf:+key-keybindings-window+)
(refresh-config-sizes object swconf:+key-keybindings-window+)
(let ((y (- (win-height *main-window*)
(win-height object)
+command-window-height+)))
(win-move object 0 y))))
(defmethod calculate ((object keybindings-window) dt)
(declare (ignore object dt)))
(defun print-suggestion-tree (window)
"Print a text representation of a tree in `window'"
(with-accessors ((keybindings-tree keybindings-tree)
(paginated-info paginated-info)
(current-page current-page)) window
(when-window-shown (window)
(win-clear window)
(win-box window)
(when paginated-info
(loop
for line in (elt paginated-info current-page)
for row-count from 1 do
(loop
for block in line
with x = 1 do
(print-text window block x row-count)
(incf x (text-width block))))))))
(defmethod draw :after ((object keybindings-window))
(labels ((column-size (column)
(let ((line (first column)))
(loop for block in line sum (text-width block)))))
(with-accessors ((keybindings-tree keybindings-tree)
(paginated-info paginated-info)
(current-page current-page)) object
(when-window-shown (object)
(win-clear object)
(win-box object)
(when paginated-info
(loop
for column in (elt paginated-info current-page)
with column-count = 1
do
(let ((column-size (column-size column)))
(loop
for row in column
with row-count = 1 do
(loop
for block in row
with x = 1 do
(print-text object block (+ x column-count) row-count)
(incf x (text-width block)))
(incf row-count))
(incf column-count column-size)))
(draw-pagination-info object))
(win-refresh object)))))
(defun build-data-for-print (data)
(keybindings:humanize-key data))
(defun build-tree-batches (window tree)
"Split the tree in column to fit the window height and pages to fit window width"
(with-accessors ((render-arrow-value render-arrow-value)
(render-leaf-value render-leaf-value)
(render-branch-value render-branch-value)
(render-spacer-value render-spacer-value)
(render-vertical-line-value render-vertical-line-value)) window
(when-let* ((tree-lines (tree->annotated-lines tree
:print-data-fn #'build-data-for-print
:arrow-char render-arrow-value
:spacer-child render-spacer-value
:child-char render-branch-value
:line-char render-vertical-line-value
:last-child-char render-leaf-value
:print-data t))
(batches (text-utils:box-fit-multiple-column-annotated tree-lines
(- (win-width window) 2)
(- (win-height window)
+box-height-diff+))))
(with-accessors ((tree-color-map tree-color-map)) window
(let ((colorized-batches (loop for batch in batches collect
(loop for column in batch collect
(loop for line in column collect
(colorize-tree-line line
tree-color-map))))))
colorized-batches)))))
(defmethod update-suggestions ((object keybindings-window) hint
&key
(tree nil)
&allow-other-keys)
"Expand the keybinding tree starting from node `hint' in slot `keybindings-tree'.
if tree is nil set the slot `keybindings-tree' to `tree'.
"
(with-accessors ((keybindings-tree keybindings-tree)
(paginated-info paginated-info)
(current-page current-page)) object
(when tree
(setf keybindings-tree tree))
(when hint
(let ((res (find-keymap-node hint keybindings-tree)))
(when (typep res 'mtree:m-tree)
(setf keybindings-tree res)
(when-let* ((paginated (build-tree-batches object keybindings-tree)))
(setf paginated-info paginated)
(setf current-page 0)))
res))))
(defun init ()
"Initialize the window"
(let* ((low-level-window (make-croatoan-window :draw-border t))
(high-level-window (make-instance 'keybindings-window
:key-config swconf:+key-keybindings-window+
:croatoan-window low-level-window)))
(refresh-config high-level-window)
(win-hide high-level-window)
high-level-window))

507
src/keybindings.lisp Normal file
View File

@ -0,0 +1,507 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/][http://www.gnu.org/licenses/]].
(in-package :keybindings)
(define-constant +control-prefix+ "^" :test #'string=)
(define-constant +meta-prefix+ "ALT-" :test #'string=)
(define-constant +function-placeholder-re+ "function-placeholder" :test #'string=)
(define-constant +function-placeholder-value+ :fn :test #'string=)
(defparameter *default-prefix* nil)
;; KEYPATH := KEY KEYPATH
;; | epsilon
;; KEY := COMMAND-KEY
;; | META-KEY
;; | KEYCODE
;; | FUNCTION-PLACEHOLDER
;; COMMAND-KEY := ( (COMMAND-MOD-1 DASH) | COMMAND-MOD-2 ) KEYCODE
;; META-KEY := META-MOD DASH KEYCODE
;; KEYCODE := NON-PRINTABLE-KEY | SIMPLE-KEY
;; SIMPLE-KEY := CHAR
;; NON-PRINTABLE-KEY := |'f1'
;; |'f2'
;; |'f3'
;; |'f4'
;; |'f5'
;; |'f6'
;; |'f7'
;; |'f8'
;; |'f9'
;; |'f10
;; | 'right'
;; | 'left'
;; | 'up'
;; | 'down'
;; | 'home'
;; | 'end'
;; | 'npage'
;; | 'ppage'
;; | "dc"
;; COMMAND-MOD-1 := 'C'
;; COMMAND-MOD-2 := '^'
;; META-MOD := 'M'
;; DASH := '-'
;; CHAR := ESCAPED-CHAR | (not ( DASH | BLANK))
;; BLANKS := BLANK*
;; BLANK := #\space | #\Newline | #\Tab
;; FUNCTION-PLACEHOLDER := 'function-placeholder'
(defrule function-placeholder "function-placeholder"
(:constant +function-placeholder-value+))
(defrule blank (or #\space #\Newline #\Tab)
(:constant nil))
(defrule blanks (* blank)
(:constant nil))
(defrule escaped-character (and #\\ character)
(:function (lambda (a) (list (second a)))))
(defrule dash #\-
(:text t))
(defrule non-printable-key
(or "f10"
"f1"
"f2"
"f3"
"f4"
"f5"
"f6"
"f7"
"f8"
"f9"
"right"
"left"
"up"
"down"
"home"
"end"
"npage" ; page down
"ppage" ; page up
"dc") ; canc
(:text t)
(:function string-upcase))
(defrule char
(or escaped-character
(not (or dash blank)))
(:text t))
(defrule meta-mod #\M
(:text t))
(defrule command-mod-1 #\C)
(defrule command-mod-2 #\^)
(defrule simple-key char)
(defrule keycode (or non-printable-key simple-key)) ; keep the order
(defun to-meta-code-string (command)
(strcat +meta-prefix+ (string-upcase (third command))))
(defrule meta-key
(and meta-mod dash keycode)
(:function to-meta-code-string)
(:text t))
(defun to-control-code-string (command)
(strcat +control-prefix+ (string-upcase (third command))))
;; not part of the actual grammar, just syntactic sugar
(defrule command-key-1
(and command-mod-1 dash keycode)
(:function to-control-code-string))
(defrule command-key-2
(and command-mod-2 keycode)
(:text t))
(defrule command-key
(or command-key-1
command-key-2))
(defrule key
(and (or function-placeholder ; keep the order
command-key
meta-key
keycode)
(? blanks))
(:function first))
(defrule keypath
(and key (? keypath))
(:function (lambda (a) (remove-if-null (flatten a)))))
(defun make-starting-comand-tree ()
(make-command-tree *default-prefix*))
(defun make-command-tree (data)
(make-instance 'sorted-m-tree
:data data
:compare-fn #'string<))
(defun parse-keypath (keypath &key (existing-tree (make-starting-comand-tree)))
"Parse a string representing a list of keys (see `*global-keymap*'),
produces a tree and graft the latter on `existing-tree'"
(labels ((placeholderp (child)
(eq +function-placeholder-value+
(data child)))
(remove-function-siblings (node)
(top-down-visit node
(lambda (a)
(if (find-if #'placeholderp (children a))
(setf (children a)
(remove-if-not #'placeholderp (children a)))))))
(remove-function-children (node)
(top-down-visit node
(lambda (a)
(when (placeholderp a)
(remove-all-children a)))))
(add (tree commands)
(if commands
(let ((new-node (make-command-tree (first commands))))
(add-child tree new-node)
(add new-node (rest commands)))
nil)))
(let ((raw (parse 'keypath (strcat keypath " " +function-placeholder-re+)))
(new-tree (make-starting-comand-tree)))
(add new-tree raw)
(graft-branch existing-tree
new-tree
:test (lambda (a b)
(cond
((functionp a)
t)
((eq b +function-placeholder-value+)
t)
(t
(string= a b)))))
(remove-function-siblings existing-tree)
(remove-function-children existing-tree)
existing-tree)))
(defparameter *global-keymap* (make-starting-comand-tree)
"The global keymap.
A keymap looks like a tree with function as leaf nodes like:
a
/ \
b c
/ / \
#'+ b d
/ \
#'* #'-
So, pressing a sequence of 'a -> c -> d' will trigger the function #'-
")
(defparameter *thread-keymap* (make-starting-comand-tree)
"The keymap for thread window.")
(defparameter *message-keymap* (make-starting-comand-tree)
"The keymap for message window.")
(defparameter *tags-keymap* (make-starting-comand-tree)
"The keymap for tags window.")
(defparameter *conversations-keymap* (make-starting-comand-tree)
"The keymap for conversations windows.")
(defparameter *send-message-keymap* (make-starting-comand-tree)
"The keymap for window to confirm sending a message.")
(defparameter *follow-requests-keymap* (make-starting-comand-tree)
"The keymap for window to accept follow requests.")
(defparameter *open-attach-keymap* (make-starting-comand-tree)
"The keymap for window to open message's attachments.")
(defun define-key (key-sequence function &optional (existing-keymap *global-keymap*))
"Define a key sequence that trigger a function:
The syntax is a simple list of keys or a single key:
- key [key ...]
where key can be either a printable character, a
<control>-character code or ALT-character. A character code can be
defined using caret notation: '^character' (e.g. '^A') or using
'C-' as placeholder for <control> (e.g. 'C-A').
The allowed character in alt-character code are downcase only.
Please note that this function will modify existing keymap.
"
(let* ((tree (parse-keypath key-sequence :existing-tree existing-keymap))
(placeholder (find-child tree +function-placeholder-value+ :compare #'eq)))
(assert placeholder)
(assert (functionp function))
(setf (data placeholder) function)
tree))
(define-constant +croatoan-last-standard-key+ 511 :test #'=)
(defclass encoded-map-entry ()
((terminal-code
:initform nil
:initarg :terminal-code
:accessor terminal-code)
(croatoan-code
:initform nil
:initarg :croatoan-code
:accessor croatoan-code)
(curses-code
:initform nil
:initarg :curses-code
:accessor curses-code))
(:documentation "terminal-code: the raw string that the terminal provide to encode a key
croatoan-code: ther symbol croatoan use and returns to usercode
curses-keycode: integer that map terminal-code
(used internally by croatoan to match croatoan-code
Example: \"^[1\" :alt-1 512.
Note that \"^]\" is the character #\Esc"))
(defmethod print-object ((object encoded-map-entry) stream)
(print-unreadable-object (object stream :type t :identity nil)
(with-accessors ((terminal-code terminal-code)
(croatoan-code croatoan-code)
(curses-code curses-code)) object
(format stream "~s ~s ~s" terminal-code croatoan-code curses-code))))
(defun make-encoded-map-entry (terminal-code croatoan-code curses-code)
(make-instance 'encoded-map-entry
:terminal-code terminal-code
:croatoan-code croatoan-code
:curses-code curses-code))
(defun term-escaped-sequence (&rest chars)
(append (list #\Esc)
chars))
(defun other-codes ()
"Others keycode (the terminal encoding is non standard and will requires tweak).
Values a list of `encoded-map-entry'"
(flet ((collect-codes (from-ascii-code below-ascii-code from-curses-code)
(loop
for character-code from from-ascii-code below below-ascii-code by 1
for curses-code from from-curses-code by 1 collect
(let ((char (code-char character-code)))
(make-encoded-map-entry (format nil "~a~a" #\Esc char) ; terminal
(format-keyword (format nil "alt-~a" char)) ; croatoan
curses-code))))) ; curses
(let* ((number-and-symbols (collect-codes 33 65 (1+ +croatoan-last-standard-key+)))
(last-curses-code (curses-code (last-elt number-and-symbols)))
(characters (collect-codes 97
127
(1+ last-curses-code))))
(setf last-curses-code (curses-code (last-elt characters)))
(let ((misc (list (make-encoded-map-entry (term-escaped-sequence #\[ #\1 #\; #\3 #\D)
:alt-left
(+ 1 last-curses-code))
(make-encoded-map-entry (term-escaped-sequence #\[ #\1 #\; #\3 #\A)
:alt-up
(+ 2 last-curses-code))
(make-encoded-map-entry (term-escaped-sequence #\[ #\1 #\; #\3 #\C)
:alt-right
(+ 3 last-curses-code))
(make-encoded-map-entry (term-escaped-sequence #\[ #\1 #\; #\3 #\B)
:alt-down
(+ 4 last-curses-code))
(make-encoded-map-entry (term-escaped-sequence #\[ #\1 #\; #\5 #\D)
:control-left
(+ 5 last-curses-code))
(make-encoded-map-entry (term-escaped-sequence #\[ #\1 #\; #\5 #\A)
:control-up
(+ 6 last-curses-code))
(make-encoded-map-entry (term-escaped-sequence #\[ #\1 #\; #\5 #\C)
:control-right
(+ 7 last-curses-code))
(make-encoded-map-entry (term-escaped-sequence #\[ #\1 #\; #\5 #\B)
:control-down
(+ 8 last-curses-code)))))
(append number-and-symbols characters misc)))))
(defparameter *local-key-alist* (other-codes))
(defun add-keymap-to-curses-db ()
"Remove nonstandard key form 'croatoan:*key-alist*' and add ours
instead"
(loop for keymapping in *local-key-alist* do
(croatoan:define-function-key (croatoan-code keymapping) (terminal-code keymapping)
:key-code (curses-code keymapping))))
(defun init-keyboard-mapping ()
(add-keymap-to-curses-db))
(defun find-keymap-node (key tree)
"Find `key' in keymap `tree'.
Returns the node of the tree or a function if the node found node
has a single children (the function to call).
If `key' can not be found returns nil.
"
(when-let* ((node-pos (num:binary-search (children tree)
(make-node key)
:compare-fn (lambda (a b)
(string< (data a) (data b)))
:equal-fn (lambda (a b)
(string= (data a) (data b)))))
(node (interfaces:clone (elt (children tree) node-pos))))
(assert (or (null node)
(not (leafp node))))
(setf (parent node) nil)
(let* ((child-with-function-to-call (find-if (lambda (child) (functionp (data child)))
(children node)))
(function-to-call (and child-with-function-to-call
(data child-with-function-to-call))))
(or function-to-call
node))))
(defun humanize-key (key)
"Transform a node of the keymap in something that humans can easly
understand"
(cond
((functionp key)
(if (documentation key t)
(with-input-from-string (stream (documentation key t))
(read-line stream))
(function-name key)))
((string= key "^J")
(_ "Enter"))
((string= key "DC")
(_ "Delete"))
((string= key "NPAGE")
(_ "Page-up"))
((string= key "PPAGE")
(_ "Page-down"))
(t
(to-s key))))
(defun key-paths (keymapping-tree)
"Transform a keymap tree in a list of path from root of the tree to
each leaf (as strings)"
(let ((all-texts ())
(all-functions ()))
(labels ((collect-fn (&optional (starting-path ()))
(let ((path (copy-list starting-path)))
(lambda (node)
(let ((data (data node)))
(push data path)
(if (functionp data)
(progn
(push (reverse path) all-texts)
(push data all-functions))
path)))))
(collect (node &optional (collector (collect-fn)))
(let* ((path-so-far (funcall collector node)))
(do-children (child node)
(let ((new-collector (collect-fn path-so-far)))
(collect child new-collector)))))
(humanize-paths (paths)
(loop for path in paths collect
(mapcar #'humanize-key (rest path))))
(build-string (paths)
(mapcar (lambda (a) (format nil "~a" (join-with-strings a " ")))
paths)))
(collect keymapping-tree)
(mapcar #'make-help-fields
(build-string (humanize-paths all-texts))
all-functions))))
(defun help-fields-get-function (fields)
(getf fields :function))
(defun help-fields-get-text (fields)
(getf fields :text))
(defun make-help-fields (text function)
(list :text text :function function))
(defun help-expand (x fields)
"Expands an entry in quick help window (see function `print-help'
and `make-blocking-list-dialog-window') showing the full docstring for a command"
(declare (ignore x))
(when-let* ((function (help-fields-get-function fields))
(bg (swconf:win-bg swconf:+key-help-dialog+))
(fg (swconf:win-fg swconf:+key-help-dialog+)))
(windows:make-blocking-message-dialog specials:*main-window*
nil
(function-name function)
(if (string-not-empty-p (documentation function t))
(split-lines (documentation function t))
(list (_ "No documentation available, you can help! :-)")))
bg
fg)))
(defun print-help (main-window)
"Generate an help text for the focused window and main window"
(multiple-value-bind (header-bg header-fg attribute-header)
(swconf:quick-help-header-colors)
(labels ((colorize-header (a)
(tui-utils:make-tui-string a
:fgcolor header-fg
:bgcolor header-bg
:attributes attribute-header))
(sort-help (help-values)
(sort help-values
(lambda (a b)
(let* ((text-a (help-fields-get-text a))
(text-b (help-fields-get-text b))
(alpha-a-p (scan "(?i)^[a-z]" text-a))
(alpha-b-p (scan "(?i)^[a-z]" text-b)))
(cond
((and alpha-a-p
alpha-b-p)
(string< text-a text-b))
(alpha-a-p
t)
(alpha-b-p
nil)
(t
(string< text-a text-b))))))))
(when-let* ((focused-keybindings (main-window:focused-keybindings main-window))
(global-help (sort-help (key-paths *global-keymap*)))
(header-focused (colorize-header (_ "Focused window keys")))
(header-global (colorize-header (_ "Global keys")))
(focused-help (sort-help (key-paths focused-keybindings)))
(global-header-fields (make-help-fields header-global nil))
(focused-header-fields (make-help-fields header-focused nil))
(fields (list focused-header-fields)))
(setf fields
(append fields
focused-help
(list global-header-fields)
global-help))
(let ((all-lines (mapcar #'help-fields-get-text
fields)))
(line-oriented-window:make-blocking-list-dialog-window specials:*main-window*
fields
all-lines
#'help-expand
(_ "Quick help")))))))

333
src/line-oriented-window.lisp Normal file
View File

@ -0,0 +1,333 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :line-oriented-window)
(defclass line ()
((selected-fg
:initform :black
:initarg :selected-fg
:accessor selected-fg
:documentation "The foreground color for a selected line")
(selected-bg
:initform :cyan
:initarg :selected-bg
:accessor selected-bg
:documentation "The background color for a selected line")
(normal-fg
:initform :cyan
:initarg :normal-fg
:accessor normal-fg
:documentation "The foreground color for a line")
(normal-bg
:initform :black
:initarg :normal-bg
:accessor normal-bg
:documentation "The background color for a line")
(normal-text
:initform (make-tui-string "...")
:initarg :normal-text
:accessor normal-text
:documentation "The actual not selected text")
(selected-text
:initform (make-tui-string "...")
:initarg :selected-text
:accessor selected-text
:documentation "The actual selected text")
(deleted-text
:initform (make-tui-string "...")
:initarg :deleted-text
:accessor deleted-text
:documentation "The actual deleted text ")
(fields
:initform ()
:initarg :fields
:accessor fields
:documentation "A generic plist of useful informations for the window")
(index
:initform 0
:initarg :index
:accessor index
:documentation "The index of this line in the window")
(selected
:initform nil
:initarg :selected
:reader selectedp
:writer (setf selected)
:documentation "Non nil if this line is selected state"))
(:documentation "This class represents a single line in a row-oriented-widget"))
(defclass row-oriented-widget ()
((rows
:initform ()
:initarg :rows
:accessor rows
:documentation "The rows of data for this widget")
(row-selected-index
:initform -1
:initarg :row-selected-index
:accessor row-selected-index
:documentation "The index of the selected row")
(single-row-height
:initform 1
:initarg :single-row-height
:accessor single-row-height
:documentation "The height of a row (in character)")
(top-row-padding
:initform 0
:initarg :top-row-padding
:accessor top-row-padding
:documentation "the padding from the top of the window and the
position where to draw the first line")
(current-row-index
:initform 0
:initarg :current-row-index
:accessor current-row-index
:documentation "The active line index")
(y-current-row
:initform 0
:initarg :y-current-row
:accessor y-current-row
:documentation "The active line position"))
(:documentation "A widget that holds a selectable list of lines"))
(defmethod initialize-instance :after ((object row-oriented-widget) &key &allow-other-keys)
(with-accessors ((top-row-padding top-row-padding)
(y-current-row y-current-row)) object
(setf y-current-row top-row-padding)))
(defmethod (setf top-row-padding) ((object row-oriented-widget) new-padding)
(setf (slot-value object 'top-row-padding) new-padding)
(setf (slot-value object 'y-current-row) new-padding)
object)
(defgeneric renderizable-rows-data (object))
(defgeneric unselect-all (object))
(defgeneric select-row (object index))
(defgeneric selected-row (object))
(defgeneric selected-row-fields (object))
(defgeneric selected-row-delete (object))
(defgeneric row-move (object amount)
(:documentation "Move selected line of 'amount'. 'Amount' can be
an integer number, if positive increase the position of the selected
line otherwise decrease, relative to current index position.
The value is clamped at range [ 0, '(length (rows object)))' ).
This function return the number of positions acually moved"))
(defmethod renderizable-rows-data ((object row-oriented-widget))
"Cut from all the lines a slice that that fits into the widget"
(with-accessors ((top-row-padding top-row-padding)
(current-row-index current-row-index)
(row-selected-index row-selected-index)
(rows rows)) object
(let* ((window-height (if (uses-border-p object)
(win-height-no-border object)
(win-height object)))
(available-rows (- window-height top-row-padding))
(selected-top-offset (rem row-selected-index available-rows))
(top (- row-selected-index selected-top-offset))
(bottom (+ row-selected-index
(- available-rows selected-top-offset))))
(values (safe-subseq rows top bottom)
selected-top-offset))))
(defmethod unselect-all ((object row-oriented-widget))
(loop for row in (rows object) do
(setf (selected row) nil))
object)
(defmethod select-row ((object row-oriented-widget) (index number))
(with-accessors ((rows rows)
(row-selected-index row-selected-index)) object
(restart-case
(if (or (< index 0)
(>= index (length rows)))
(error 'conditions:out-of-bounds :idx index :seq rows)
(progn
(setf row-selected-index index)
(setf (selected (elt rows index)) t)))
(ignore-selecting-action (e)
(declare (ignore e))
nil))
object))
(defmethod selected-row ((object row-oriented-widget))
"Return the current selected row"
(with-accessors ((rows rows)
(row-selected-index row-selected-index)) object
(when rows
(if (<= 0
row-selected-index
(1- (length rows)))
(elt rows row-selected-index)
nil))))
(defmethod selected-row-fields ((object row-oriented-widget))
"Return the fields current selected row"
(when-let ((selected-row (selected-row object)))
(fields selected-row)))
(defmethod selected-row-delete ((object row-oriented-widget))
"delete the selected row"
(with-accessors ((rows rows)
(row-selected-index row-selected-index)) object
(let ((last-was-removed-p (= row-selected-index
(1- (length rows)))))
(setf rows (remove-if #'selectedp rows))
(when rows
(if last-was-removed-p
(select-row object (1- row-selected-index))
(select-row object row-selected-index)))))
object)
(defmethod row-move ((object row-oriented-widget) amount)
"Navigate the lines, move the selected row by `amount', returns the
actual of rows moved. This can be different from `amount' if moving
this exact quantity wold go beyond the length or fows or zero."
(with-accessors ((rows rows)
(row-selected-index row-selected-index)) object
(when (/= 0 amount)
(let* ((desired-amount (+ amount row-selected-index))
(actual-amount (if (< amount 0)
(max (- desired-amount
row-selected-index)
(- row-selected-index))
(- (min desired-amount
(1- (length rows)))
row-selected-index))))
(select-row object (+ row-selected-index
actual-amount))
actual-amount))))
(defclass simple-line-navigation-window (wrapper-window row-oriented-widget border-window)
((selected-line-bg
:initarg :selected-line-bg
:accessor selected-line-bg
:documentation "The background color for a selected line")
(selected-line-fg
:initarg :selected-line-fg
:accessor selected-line-fg
:documentation "The foreground color for a selected line"))
(:documentation "A window that displays a navigable list of objects"))
(defmethod draw :after ((object simple-line-navigation-window))
(with-accessors ((uses-border-p uses-border-p)
(single-row-height single-row-height)
(top-row-padding top-row-padding)) object
(let ((max-line-size (if uses-border-p
(win-width-no-border object)
(win-width object))))
(let ((rows (renderizable-rows-data object))
(x (if (uses-border-p object)
1
0)))
(loop
for y from (1+ top-row-padding) by single-row-height
for ct from 0
for row in rows do
(if (selectedp row)
(print-text object
(right-pad-text (text-ellipsize (selected-text row)
max-line-size)
max-line-size)
x y
:bgcolor (selected-bg row)
:fgcolor (selected-fg row))
(print-text object
(right-pad-text (text-ellipsize (normal-text row)
max-line-size)
max-line-size)
x y
:bgcolor (normal-bg row)
:fgcolor (normal-fg row))))))))
(defgeneric resync-rows-db (object &key redraw)
(:documentation "Synchronize information table slot of `object` with
table in the database, if `redraw` is not nil redraw the object, if
possible"))
(defun make-blocking-list-dialog-window (screen all-fields text-lines callback
&optional (title (_ "Information")))
"Draw a window with a scrollable list of entries, pressing enter
will fire the `callback' function (with the selected field from `all-fields'
and text from `text-line'. This window is fitten into `screen' sizes."
(assert (length= all-fields text-lines))
(let* ((low-level-window (make-blocking-croatoan-window :enable-function-keys t))
(window-width (max (+ 4
(length title))
(+ (find-max-line-width text-lines)
2)))
(window-height (min (truncate (* 0.9 (win-height screen)))
(+ (length text-lines) 2)))
(window-x (truncate (- (* 0.5 (win-width screen))
(* 0.5 window-width))))
(window-y (truncate (- (* 0.5 (win-height screen))
(* 0.5 window-height))))
(bg (swconf:win-bg swconf:+key-info-dialog+))
(fg (swconf:win-fg swconf:+key-info-dialog+))
(high-level-window (make-instance 'simple-line-navigation-window
:single-row-height 1
:uses-border-p t
:croatoan-window low-level-window)))
(flet ((draw ()
(win-clear high-level-window :redraw nil)
(draw high-level-window)
(win-box high-level-window)
(print-text high-level-window title 2 0)))
(setf (background low-level-window)
(tui:make-background bg))
(setf (fgcolor low-level-window)
fg)
(win-resize high-level-window window-width window-height)
(win-move high-level-window window-x window-y)
(setf (rows high-level-window)
(loop
for text in text-lines
for fields in all-fields
collect
(make-instance 'line
:fields fields
:normal-text text
:selected-text text
:normal-bg bg
:normal-fg fg
:selected-bg fg
:selected-fg bg)))
(select-row high-level-window 0)
(draw)
(loop named inner
for c = (get-wide-event low-level-window)
while (string/= c "q")
do
(cond
((string= c :up)
(unselect-all high-level-window)
(row-move high-level-window -1))
((string= c :down)
(unselect-all high-level-window)
(row-move high-level-window 1))
((string= c #\Newline)
(let ((selected-fields (selected-row-fields high-level-window))
(selected-text (selected-text (selected-row high-level-window))))
(funcall callback selected-text selected-fields))))
(draw))
(win-close high-level-window))))

77
src/main-window.lisp Normal file
View File

@ -0,0 +1,77 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :main-window)
(defclass main-window (wrapper-window)
((focused-window
:initform nil
:initarg :focused-window
:accessor focused-window
:documentation "The window with the focus, only a window can get
the focus at the same time"))
(:documentation "the main window AKA the screen"))
(defmethod refresh-config :after ((object main-window))
(refresh-config-colors object swconf:+key-main-window+))
(defmethod calculate ((object main-window) dt)
(do-children (child object)
(calculate child dt)))
(defmethod draw ((object main-window))
(do-children (child object)
(draw child)))
(defgeneric focused-keybindings (object))
(defmethod focused-keybindings ((object main-window))
"Return the keymap of the window with focus"
(with-accessors ((focused-window focused-window)) object
(when focused-window
(when-let ((keybindings (keybindings focused-window)))
keybindings))))
(defun init ()
"Initialize the screen"
(let ((screen (make-screen)))
(setf *main-window*
(make-instance 'main-window
:keybindings keybindings:*global-keymap*
:key-config swconf:+key-main-window+
:croatoan-window screen))
(refresh-config *main-window*)
*main-window*))
(defun parse-subwin-size (size-as-string main-window-size)
"Parse a window size, size is a fraction of the main window size"
(let* ((raw (num:safe-parse-number size-as-string
:fix-fn (lambda (e)
(declare (ignore e))
main-window-size))))
(cond
((integerp raw)
raw)
(t
(truncate (* raw main-window-size))))))
(defun parse-subwin-w (w-as-string)
"Parse a window width, `w-as-string' a fraction of the main window width"
(parse-subwin-size w-as-string (win-width *main-window*)))
(defun parse-subwin-h (h-as-string)
"Parse a window height, `h-as-string' a fraction of the main window height"
(parse-subwin-size h-as-string (win-height *main-window*)))

149
src/main.lisp Normal file
View File

@ -0,0 +1,149 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/][http://www.gnu.org/licenses/]].
(in-package :main)
(defparameter *tick* 0.0)
(define-constant +dt+ (/ 1 +fps+) :test #'=)
(defun incf-dt ()
(incf *tick* +dt+))
(defun setup-bindings ()
"This is where an UI event is bound to a function the event nil is
the event that is fired wnen no input from user (key pressed mouse
etc.) happened"
(windows:with-croatoan-window (croatoan-window specials:*main-window*)
(bind croatoan-window
:resize
(lambda (w event)
(declare (ignore w event))
(windows:refresh-config-all)
(windows:draw-all)))
(bind croatoan-window
t
(lambda (w event)
(declare (ignore w))
(incf-dt)
(handler-bind ((conditions:command-not-found
(lambda (e)
(invoke-restart 'command-window:print-error e))))
(command-window:manage-event event))))
;; this is the main thread
(bind croatoan-window
nil
(lambda (w e)
(declare (ignore w e))
(incf-dt)
(program-events:dispatch-program-events)
(windows:calculate-all +dt+)))))
(defun init-i18n ()
"Initialize i18n machinery"
(handler-bind ((error
(lambda (e)
(declare (ignore e))
(invoke-restart 'cl-i18n:return-empty-translation-table))))
(setf cl-i18n:*translation-file-root* +catalog-dir+)
(cl-i18n:load-language +text-domain+ :locale (cl-i18n:find-locale))))
(defun init-db ()
"Initialize the database"
(db-utils:with-ready-database (:connect t)
(db:purge-history)))
(defun change-folder ()
"Change folder, used in requests of a command line switch"
(let ((refresh-event (make-instance 'program-events:refresh-thread-windows-event
:new-folder command-line:*start-folder*))
(folder-exists-p (db:folder-exists-p command-line:*start-folder*)))
(when folder-exists-p
(program-events:push-event refresh-event))))
(defun change-timeline ()
"Change timeline, used in requests of a command line switch"
(let* ((refresh-event (make-instance 'program-events:refresh-thread-windows-event
:new-timeline command-line:*start-timeline*)))
(program-events:push-event refresh-event)))
(defun init ()
"Initialize the program"
(res:init)
(swconf:load-config-file)
(init-db)
(db-utils:with-ready-database (:connect nil)
(modules:load-module +starting-init-file+)
;; init main window for first...
(main-window:init)
(keybindings-window:init)
(command-window:init)
(thread-window:init)
;; the size of message and tag window depends from the sizes of
;; thread-window and command window, so the first two must be
;; initialized after the latter
(message-window:init)
(tags-window:init)
(conversations-window:init)
(setup-bindings)
;; ... and init-keyboard-mapping-for last
(keybindings:init-keyboard-mapping)
(ui:focus-to-thread-window)
;; now init the client
(client:init)
(client:authorize)
(when command-line:*start-folder*
(change-folder))
(when command-line:*start-timeline*
(change-timeline))
(when command-line:*update-timeline*
(ui:update-current-timeline))
(when command-line:*check-follow-requests*
(ui:start-follow-request-processing))))
(defun run ()
(windows:with-croatoan-window (croatoan-window specials:*main-window*)
(setf (frame-rate croatoan-window) +fps+)
(db-utils:with-ready-database (:connect nil)
(unwind-protect
(progn
(hooks:run-hooks 'hooks:*before-main-loop*)
(run-event-loop croatoan-window))
(end-screen)))))
(defun load-script-file ()
"Load (exexute) a lisp file used in requests of a command line switch"
(setf program-events:*process-events-immediately* t)
(swconf:load-config-file)
(init-db)
(db-utils:with-ready-database (:connect nil)
(client:init)
(client:authorize)
(load command-line:*script-file* :verbose nil :print nil)))
(defun main ()
"The entry point function of the program"
(init-i18n)
(command-line:manage-opts)
(if command-line:*script-file*
(load-script-file)
(let ((croatoan::*debugger-hook* #'(lambda (c h)
(declare (ignore h))
(end-screen)
(print c))))
(init)
(run))))

232
src/message-rendering-utils.lisp Normal file
View File

@ -0,0 +1,232 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :message-rendering-utils)
(defun mention-p (maybe-mention)
(scan (strcat "^" +mention-prefix+)
maybe-mention))
(defun add-mention-prefix (username)
(if (mention-p username)
username
(strcat +mention-prefix+ username)))
(defun strip-mention-prefix (maybe-mention)
(if (not (mention-p maybe-mention))
maybe-mention
(subseq maybe-mention (length +mention-prefix+))))
(defun find-first-mention-in-message (message-body)
(when message-body
(with-input-from-string (body-stream message-body)
(when-let* ((first-line (read-line body-stream nil ""))
(mentions (split-words first-line))
(first-mention (first mentions)))
(when (mention-p first-mention)
first-mention)))))
(defun crypto-message-destination-user (message-data)
(with-accessors ((body sending-message:body)
(subject sending-message:subject)
(reply-to sending-message:reply-to)
(visibility sending-message:visibility)) message-data
(when (string= visibility
+status-direct-visibility+)
(if reply-to
(let ((reply-username (status-id->username reply-to)))
(db:username->id reply-username))
(when-let* ((mention (find-first-mention-in-message body))
(user (db:user-exists-p (msg-utils:strip-mention-prefix mention)))
(username (db:row-user-username user)))
(db:username->id username))))))
(defun maybe-crypt-message (send-message-window &key (notify-cant-crypt nil))
(with-accessors ((message-data sending-message:message-data)
(rows line-oriented-window:rows)) send-message-window
(with-accessors ((body sending-message:body)
(subject sending-message:subject)
(reply-to sending-message:reply-to)
(visibility sending-message:visibility)) message-data
(when (string= visibility
+status-direct-visibility+)
(let ((destination-user-id (crypto-message-destination-user message-data)))
(if (null destination-user-id)
(when notify-cant-crypt
(ui:notify (_ "This message will *not* be crypted")))
(let* ((destination-username (db:user-id->username destination-user-id))
(destination-mention (msg-utils:add-mention-prefix destination-username))
(new-body (misc:make-fresh-array 0 #\Space 'character nil))
(crypto-key (db:crypto-user-key destination-username)))
(if (null crypto-key)
(when notify-cant-crypt
(ui:notify (format nil
(_ "No key to crypt message for ~s found")
destination-username)))
(with-output-to-string (body-stream new-body)
;; add username on top
(format body-stream "~a~%" destination-mention)
(format body-stream
"~a~%"
(crypto-utils:encrypt-message body crypto-key))
(setf body new-body))))))))))
(defun find-crypto-data (text)
(with-input-from-string (stream text)
(loop for line = (read-line stream nil nil)
while line
do
(when (crypto-utils:crypto-text-p line)
(return-from find-crypto-data line))))
nil)
(defun maybe-decrypt-message (message-row message-text &key (notify-cant-decrypt nil))
(let* ((username (db:row-message-username message-row))
(html-stripped (html-utils:html->text (db:row-message-content message-row)
:add-link-footnotes nil))
(mention (find-first-mention-in-message html-stripped))
(reply-p (db:row-message-reply-to-id message-row))
(crypto-key (cond
(reply-p
(db:crypto-user-key username))
(mention
(db:crypto-user-key (msg-utils:strip-mention-prefix mention)))
(t
nil)))
(crypto-data (find-crypto-data message-text)))
(if crypto-data
(if (and (null crypto-key)
notify-cant-decrypt)
(ui:notify (format nil
(_ "Unable to find the crypto key for user ~s.")
username)
:as-error t)
(crypto-utils:decrypt-message crypto-data crypto-key))
nil)))
(defun attachment-type->description (type)
(macrolet ((gen-cond (key types descriptions)
`(cond
,@(append
(loop
for type in types
for description in descriptions collect
`((string-equal ,type ,key) ,description))
`((t
(_ "invalid type")))))))
(gen-cond type
("unknown" "image" "gifv" "video" "audio")
((_ "unknown") (_ "image") (_ "gifv") (_ "video") (_ "audio")))))
(defun attachment-type->metadata (type row)
(let ((data (misc:make-fresh-array 0 #\a 'character nil)))
(with-output-to-string (stream data)
(format stream
(_ "description: ~a~%")
(db-utils:db-getf row :description))
(format stream
(_ "size: ~aX~a pixels~%")
(db-utils:db-getf row :width)
(db-utils:db-getf row :height))
(when (or (string-equal type "gifv")
(string-equal type "video")
(string-equal type "audio"))
(format stream
(_"duration: ~a~%")
(db-utils:db-getf row :duration))))
data))
(defun status-attachments->text (status-id)
(let ((text (misc:make-fresh-array 0 #\Space 'character nil)))
(when-let* ((all-attachments (db:all-attachments-to-status status-id)))
(with-output-to-string (stream text)
(multiple-value-bind (header-prefix header-postfix header-value)
(swconf:message-window-attachments-header)
(let ((actual-header-value (or header-value
(_ "Attachments"))))
(format stream (strcat header-prefix
actual-header-value
header-postfix))))
(loop for attachment in all-attachments do
(let ((type (db-utils:db-getf attachment
:type
(_ "unknown"))))
(format stream
(_"type: ~a~%metadata~%~a~%address: ~a~2%")
(attachment-type->description type)
(attachment-type->metadata type attachment)
(db-utils:db-getf attachment :url (_ "unknown")))))))
text))
(defgeneric message-original->text-body (object &key &allow-other-keys))
(defmethod message-original->text-body ((object string) &key &allow-other-keys)
(let* ((raw-body (html-utils:html->text object)))
(emoji-shortcodes:emojify raw-body)))
(defun prepend-crypto-marker (decrypted-text)
(format nil "~a~2%~a" (swconf:crypted-mark-value) decrypted-text))
(defmethod message-original->text-body ((object null) &key &allow-other-keys)
(declare (ignore object))
"")
(defmethod message-original->text-body ((object list)
&key
(notify-cant-decrypt nil)
(try-decrypt nil)
&allow-other-keys)
(let ((as-text (message-original->text-body (db:row-message-content object))))
(if try-decrypt
(let ((decrypted (maybe-decrypt-message object
as-text
:notify-cant-decrypt notify-cant-decrypt)))
(if decrypted
(message-original->text-body (prepend-crypto-marker decrypted))
as-text))
as-text)))
(defun message-original->text-header (message-row)
(let* ((date-format (swconf:date-fmt swconf:+key-message-window+))
(username (db:row-message-username message-row))
(display-name (db:row-message-user-display-name message-row))
(creation-time (db:row-message-creation-time message-row))
(lockedp (db-utils:db-not-nil-p (db:row-lockedp message-row)))
(locked-mark (swconf:message-window-account-locking-status-mark lockedp))
(encoded-date (db-utils:encode-datetime-string creation-time))
(from-label (_ "From: "))
(boosted-label (_ "Boosted: "))
(boosted-id (db:row-message-reblog-id message-row))
(boosted-username (and boosted-id
(db:status-id->username boosted-id)))
(date-label (_ "Date: "))
(padding-length (max (length from-label)
(length date-label)
(length boosted-label)))
(text (misc:make-fresh-array 0 #\Space 'character nil)))
(with-output-to-string (stream text)
(format stream
"~a(~a) ~a~a~%"
(right-padding from-label padding-length)
display-name username locked-mark)
(format stream "~a~a~2%"
(right-padding date-label padding-length)
(format-time encoded-date date-format))
(when boosted-id
(format stream "~a~a~%"
(right-padding boosted-label padding-length)
boosted-username)))
text))

224
src/message-window.lisp Normal file
View File

@ -0,0 +1,224 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :message-window)
(defclass message-window (wrapper-window
row-oriented-widget
focus-marked-window
title-window)
((source-text
:initform nil
:initarg :source-text
:reader source-text)
(line-position-mark
:initform (make-tui-string "0")
:initarg :line-position-mark
:accessor line-position-mark)))
(defgeneric prepare-for-rendering (object))
(defmethod prepare-for-rendering ((object message-window))
(flet ((fit-lines (lines)
(let ((res ()))
(loop for line in lines do
(if (string-empty-p line)
(push nil res)
(loop
for fitted-line in
(flush-left-mono-text (split-words line)
(win-width-no-border object))
do
(push fitted-line res))))
(reverse res))))
(with-accessors ((source-text source-text)) object
(when hooks:*before-prepare-for-rendering-message*
(hooks:run-hook 'hooks:*before-prepare-for-rendering-message* object))
(let* ((lines (split-lines source-text))
(fitted-lines (fit-lines lines))
(color-re (swconf:color-regexps))
(new-rows (loop for line in fitted-lines collect
(let ((res line))
(loop for re in color-re do
(setf res (colorize-line res re)))
(colorized-line->tui-string res)))))
(setf (rows object)
(mapcar (lambda (text-line)
(make-instance 'line
:normal-text text-line))
new-rows))
(select-row object 0)
object))))
(defmethod (setf source-text) (new-text (object message-window))
(setf (slot-value object 'source-text) new-text)
(prepare-for-rendering object))
(defun refresh-line-mark-config (window)
(multiple-value-bind (mark-value mark-fg mark-bg)
(swconf:message-window-line-mark-values)
(setf (line-position-mark window)
(make-tui-string mark-value
:fgcolor mark-fg
:bgcolor mark-bg))))
(defmethod refresh-config :after ((object message-window))
(refresh-config-colors object swconf:+key-message-window+)
(refresh-line-mark-config object)
(let* ((thread-window-width (win-width *thread-window*))
(thread-window-height (win-height *thread-window*))
(command-window-height (win-height *command-window*))
(main-window-height (win-height *main-window*))
(height (- main-window-height
command-window-height
thread-window-height))
(width thread-window-width)
(x (win-x *thread-window*))
(y (+ (win-y *thread-window*)
thread-window-height)))
(win-resize object width height)
(win-move object x y)))
(defmethod calculate ((object message-window) dt)
(declare (ignore object dt)))
(defun draw-text (window)
(with-accessors ((rows rows)
(row-selected-index row-selected-index)) window
(let ((actual-rows (safe-subseq rows row-selected-index)))
(loop
for line in actual-rows
for y from 1 below (win-height-no-border window) do
(let ((text-line (normal-text line)))
(when (string-not-empty-p text-line)
(print-text window text-line 1 y)))))))
(defun draw-buffer-line-mark (window)
(with-accessors ((rows rows)
(row-selected-index row-selected-index)
(line-position-mark line-position-mark)) window
(let* ((height (1- (win-height-no-border window)))
(rows-count (length rows))
(fraction (/ row-selected-index
(max 1 (1- rows-count))))
(mark-y (1+ (truncate (* fraction height))))
(mark-x (1- (win-width window))))
(print-text window line-position-mark mark-x mark-y))))
(defmethod draw ((object message-window))
(when-window-shown (object)
(win-clear object :redraw nil)
(win-box object)
(draw-text object)
(when (source-text object)
(draw-buffer-line-mark object))
(call-next-method)))
(defgeneric scroll-down (object &optional amount))
(defgeneric scroll-up (object &optional amount))
(defgeneric scroll-end (object))
(defgeneric scroll-begin (object))
(defgeneric scroll-next-page (object))
(defgeneric scroll-previous-page (object))
(defgeneric search-regex (object regex))
(defmethod scroll-down ((object message-window) &optional (amount 1))
(when (/= (row-move object amount)
0)
(draw object)))
(defmethod scroll-up ((object message-window) &optional (amount 1))
(when (/= (row-move object (- amount))
0)
(draw object)))
(defmethod scroll-end ((object message-window))
(with-accessors ((rows rows)
(row-selected-index row-selected-index)) object
(when (/= (row-move object (- (length rows) row-selected-index))
0)
(draw object))))
(defmethod scroll-begin ((object message-window))
(with-accessors ((rows rows)
(row-selected-index row-selected-index)) object
(when (/= (row-move object (- row-selected-index))
0)
(draw object))))
(defmethod scroll-next-page ((object message-window))
(with-accessors ((rows rows)
(row-selected-index row-selected-index)) object
(let ((actual-window-height (win-height-no-border object)))
(when (and (> (- (length rows)
row-selected-index)
actual-window-height)
(/= (row-move object actual-window-height)
0))
(draw object)))))
(defmethod scroll-previous-page ((object message-window))
(when (/= (row-move object (- (win-height-no-border object)))
0)
(draw object)))
(defun first-line->string (window)
(with-accessors ((rows rows)
(row-selected-index row-selected-index)) window
(tui-string->chars-string (normal-text (elt rows row-selected-index)))))
(defmethod search-regex ((object message-window) regex)
(with-accessors ((rows rows)
(row-selected-index row-selected-index)) object
(let ((line-found (position-if (lambda (a)
(scan regex
(tui-string->chars-string (normal-text a))))
rows
:start (min (1+ row-selected-index)
(length rows)))))
(when line-found
(row-move object (- line-found row-selected-index))
(draw object)
(let ((line (first-line->string object)))
(labels ((highlight (&optional (start-scan 0))
(multiple-value-bind (start end)
(scan regex line :start start-scan)
(when start
(let ((mask (make-tui-string (subseq line start end)
:fgcolor (win-bgcolor object)
:bgcolor (win-fgcolor object))))
(print-text object mask (1+ start) 1)
(highlight end))))))
(highlight)))))))
(defun init ()
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
(setf *message-window*
(make-instance 'message-window
:title (_ "Messages")
:keybindings keybindings:*message-keymap*
:key-config swconf:+key-message-window+
:croatoan-window low-level-window))
(refresh-config *message-window*)
(draw *message-window*)
*message-window*))

919
src/misc-utils.lisp Normal file
View File

@ -0,0 +1,919 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
;; uses code from
;; niccolo': a chemicals inventory
;; Copyright (C) 2016 Universita' degli Studi di Palermo
;; 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, 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/>.
(in-package :misc-utils)
;; debug utils
(defparameter *debug* nil)
(defmacro when-debug (&body body)
`(when (not (null *debug*))
,@body))
(defun debug-log (format-string &rest parameters)
(when (not (log:debug))
(log4cl:remove-all-appenders log4cl:*root-logger*)
(log:config :debug :nopackage
:daily (text-utils:strcat (res:home-datadir)
"tinmop.log")
:backup nil))
(let ((message (apply #'format nil format-string parameters)))
(log:debug message)))
(defun dbg (format-string &rest parameters)
(apply #'debug-log format-string parameters))
(defun dbg-and-quit (format-string &rest parameters)
(apply #'dbg format-string parameters)
(uiop:quit))
(defun dbg-stdout (format-string &rest parameters)
((lambda (a b)
(apply #'format t a b))
(concatenate 'string format-string "~%")
parameters))
(defun dump-hash-table (table)
(let ((res '()))
(maphash (lambda (k v) (push (format nil "~s -> ~s~%" k v) res)) table)
res))
(defgeneric dump-hashtable (table))
(defmethod dump-hashtable ((table hash-table))
(maphash (lambda (k v) (misc:dbg "~s -> ~s" k v)) table))
(defmethod dump-hashtable (table)
(dbg "~s"table))
(defmacro with-messages-start-end ((start-message end-message
&key (print-only-if-debug-mode t)) &body body)
(alexandria:with-gensyms (res)
(let* ((debug-p (find :debug-mode *features*))
(print-msg-p (or (not print-only-if-debug-mode)
debug-p)))
`(progn
,(when print-msg-p
`(dbg ,start-message))
(let ((,res (progn ,@body)))
,(when print-msg-p
`(dbg ,end-message))
,res)))))
;; macro utils
(defmacro format-fn-symbol (package format &rest format-args)
`(alexandria:format-symbol ,package ,(concatenate 'string "~:@(" format "~)")
,@format-args))
(defun format-keyword (thing)
(alexandria:make-keyword (format nil "~:@(~a~)" thing)))
(defun check-body-keywords (body ammitted)
(let ((all-keywords (loop
for ct from 1
for i in body when (and (oddp ct)
(keywordp i))
collect i)))
(loop for i in all-keywords do
(when (not (find i ammitted :test #'eq))
(error (format nil "keyword must be one of ~a, but ~a was found"
ammitted
i))))))
;; functions utils
(defun function-name (data)
"Implementation dependent"
(assert (functionp data))
(multiple-value-bind (x y name)
(function-lambda-expression data)
(declare (ignore x y))
(if name
(string-downcase (symbol-name name))
data)))
(defmacro fn-delay (a)
(if (symbolp a)
`(lambda (&rest p) (apply (function ,a) p))
`(lambda (&rest p) (apply ,a p))))
(defun unsplice (form)
(and form
(list form)))
(defmacro defalias (alias &body (def &optional docstring))
"Define a value as a top-level function.
(defalias string-gensym (compose #'gensym #'string))
Like (setf (fdefinition ALIAS) DEF), but with a place to put
documentation and some niceties to placate the compiler.
Name from Emacs Lisp."
`(progn
;; Give the function a temporary definition at compile time so
;; the compiler doesn't complain about it's being undefined.
(eval-when (:compile-toplevel)
(unless (fboundp ',alias)
(defun ,alias (&rest args)
(declare (ignore args)))))
(eval-when (:load-toplevel :execute)
(compile ',alias ,def)
,@(unsplice
(when docstring
`(setf (documentation ',alias 'function) ,docstring))))
',alias))
(defun a->function (a)
(cond
((functionp a)
a)
((symbolp a)
(symbol-function a))))
(defmacro gen-type-p (name)
(alexandria:with-gensyms (a)
(let ((fname (if (cl-ppcre:scan "-" (symbol-name name))
(alexandria:format-symbol t "~:@(~a-p~)"
(symbol-name name))
(alexandria:format-symbol t "~:@(~ap~)"
(symbol-name name)))))
`(defun ,fname (,a)
(eql (type-of ,a) ',name)))))
(defmacro define-compiler-macros (name &body args)
(alexandria:with-gensyms (low-level-function-name)
(let* ((function-name (alexandria:format-symbol t "~:@(~a~)" name)))
`(progn
(defalias ,low-level-function-name #',function-name)
(define-compiler-macro ,function-name (&whole form ,@args)
(let ((low-funname ',low-level-function-name))
(if (every #'constantp (list ,@args))
(funcall (symbol-function low-funname) ,@args)
(progn
form))))))))
(defmacro definline (name arg &rest body)
(let* ((function-name (alexandria:format-symbol t "~:@(~a~)" name)))
`(progn
(declaim (inline ,function-name))
(defun ,function-name (,@arg) ,@body))))
(defmacro defun-inline-function (name arg &body body)
(let* ((function-name (alexandria:format-symbol t "~:@(~a~)" name))
(low-level-function-name (alexandria:format-symbol t "~:@(%~a~)" name)))
`(progn
(declaim (inline ,function-name))
(defun ,function-name (,@arg) (,low-level-function-name ,@arg))
(defun ,low-level-function-name (,@arg) ,@body))))
(defmacro defmethod-inline-function (name arg &body body)
(let* ((function-name (alexandria:format-symbol t "~:@(~a~)" name))
(low-level-function-name (alexandria:format-symbol t "~:@(%~a~)" name)))
`(progn
(declaim (inline ,function-name))
(defgeneric ,low-level-function-name (,@(loop for i in arg collect
(if (atom i)
i
(first i)))))
(defmethod ,function-name (,@arg) (,low-level-function-name
,@(loop for i in arg collect
(if (atom i)
i
(first i)))))
(defmethod ,low-level-function-name (,@arg) ,@body))))
(alexandria:define-constant +cache-invalid-value+ :invalid-cache-value :test #'eq)
(defmacro defcached (name (arg &key (test 'equalp) (clear-cache nil))
declaration
(&body body))
(let* ((function-clear-cache-name (format-fn-symbol t "~a-clear-cache" name))
(function-name (format-fn-symbol t "~:@(~a~)" name))
(cache-name (format-fn-symbol t "~:@(cache~)")))
`(let ((,cache-name (make-hash-table :test (quote ,test))))
(defun ,function-clear-cache-name () (clrhash ,cache-name))
(defun ,function-name (,@arg) ,(if declaration
declaration
`(declare (optimize (speed 0) (safety 3) (debug 3))))
(and ,clear-cache (setf ,cache-name (make-hash-table :test (quote ,test))))
,@(list body)))))
(defmacro defcached-list (name (args &key (equal-fn #'=))
&body body)
"Uses a list as cache storage, good only with few elements!"
(let* ((function-clear-cache-name (format-fn-symbol t "~a-clear-cache" name))
(function-search-cache-name (format-fn-symbol t "~a-search-cache" name))
(function-ins-cache-name (format-fn-symbol t "~a-insert-cache" name))
(function-name (format-fn-symbol t "~:@(~a~)" name)))
(multiple-value-bind (forms declaration)
(alexandria:parse-body body)
(alexandria:with-gensyms (cache)
`(let ((,cache '()))
(defun ,function-clear-cache-name ()
(setf ,cache '()))
(defun ,function-search-cache-name (d)
(find d ,cache :test ,equal-fn))
(defun ,function-ins-cache-name (d)
(pushnew d ,cache :test ,equal-fn))
(defun ,function-name (,@args)
,@declaration
,@forms))))))
(defun nest-expressions (data &optional (leaf nil))
(if (null data)
(list leaf)
(append (first data) (if (rest data)
(list (nest-expressions (rest data) leaf))
(nest-expressions (rest data) leaf)))))
(defun replace-e! (expr num)
(if (null (first expr))
nil
(if (atom (first expr))
(append (list
(if (eq (first expr) :e!)
num
(first expr)))
(replace-e! (rest expr) num))
(append (list (replace-e! (first expr) num))
(replace-e! (rest expr) num)))))
(alexandria:define-constant +nil-equiv-bag+ '(:none :false :nil) :test #'equalp)
(defun build-plist (params)
(let ((keywords (mapcar #'alexandria:make-keyword
(loop for i from 0 below (length params) when (oddp (1+ i))
collect (elt params i))))
(vals (mapcar #'(lambda (a)
(typecase a
(symbol (let ((key (alexandria:make-keyword a)))
(and (not (find key +nil-equiv-bag+ :test #'eq))
key)))
(cons (list a))
(otherwise a)))
(loop for i from 0 below (length params) when (evenp (1+ i))
collect (elt params i)))))
(mapcar #'(lambda (a b) (cons a b)) keywords vals)))
(defmacro build-assocs-chain (path start)
(if (null path)
start
`(cdr (assoc ,(first path) (build-assocs-chain ,(rest path) ,start)))))
(defmacro gen-trivial-plist-predicate (name class var get-fn)
(let ((name-fn (alexandria:format-symbol t "~:@(~a-p~)" name)))
`(progn
(defgeneric ,name-fn (object))
(defmethod ,name-fn ((object ,class))
(funcall ,get-fn object ,var)))))
(defmacro gen-trivial-plist-predicates (class get-fn &rest vars)
`(progn
,@(loop for v in vars collect
`(gen-trivial-plist-predicate ,(alexandria:symbolicate (string-trim "+" v))
,class
,v
(function ,get-fn)))))
(defmacro gen-trivial-plist-get (function-name-prefix name class var get-fn)
(let ((name-fn (alexandria:format-symbol t "~:@(~a-~a~)" function-name-prefix name)))
`(progn
(defgeneric ,name-fn (object))
(defmethod ,name-fn ((object ,class))
(funcall ,get-fn object ,var)))))
(defmacro gen-trivial-plist-gets (class get-fn function-name-prefix &rest vars)
`(progn
,@(loop for v in vars collect
`(gen-trivial-plist-get ,function-name-prefix
,(alexandria:symbolicate (string-trim "+" v))
,class
,v
(function ,get-fn)))))
;; plist
(defun recursive-assoc (path start)
(if (null path)
start
(recursive-assoc (rest path) (cdr (assoc (first path) start)))))
(defun recursive-assoc-just-before (path start)
(if (= (length path) 1)
start
(recursive-assoc-just-before (rest path) (cdr (assoc (first path) start)))))
(defun n-setf-path-value (db path new-value)
(let* ((ptr (recursive-assoc-just-before path db))
(last-key (alexandria:last-elt path))
(last-cons (assoc last-key ptr)))
(if last-cons
(values (setf (cdr last-cons) new-value) t)
(values nil nil))))
(defun plist-path-value (db path)
(let* ((ptr (recursive-assoc-just-before path db))
(last-key (alexandria:last-elt path))
(last-cons (assoc last-key ptr)))
(if last-cons
(values (cdr last-cons) t)
(values nil nil))))
;; misc
(defun not-null-p (a)
(not (null a)))
(definline code->char (code &key (limit-to-ascii nil))
(code-char (if limit-to-ascii
(alexandria:clamp code 0 127)
code)))
(definline char->code (code)
(char-code code))
(defmacro swap (a b)
`(rotatef ,a ,b))
;;;; binary files utils
;;;; big endian...
(defun 2byte->word (byte1 byte2) ;; little endian
(let ((res #x00000000))
(boole boole-ior
(boole boole-ior byte1 res)
(ash byte2 8))))
(defun 2word->int (word1 word2)
(let ((res #x00000000))
(boole boole-ior
(ash (boole boole-ior word1 res) 16)
word2)))
(defun byte->int (bytes)
(let ((res #x0000000000000000)
(ct 0))
(map nil #'(lambda (a)
(setf res (boole boole-ior
(ash a ct)
res))
(incf ct 8))
bytes)
res))
(defmacro gen-intn->bytes (bits)
(let ((function-name (alexandria:format-symbol t "~:@(int~a->bytes~)" bits)))
`(defun ,function-name (val &optional (count 0) (res '()))
(if (>= count ,(/ bits 8))
(reverse res)
(,function-name (ash val -8)
(1+ count)
(push (boole boole-and val #x00ff)
res))))))
(gen-intn->bytes 16)
(gen-intn->bytes 32)
(defun bytes->string (bytes)
(coerce (mapcar #'code-char bytes) 'string))
(defun read-ieee-float-32 (stream)
(let ((bytes (make-fresh-list 4)))
(read-sequence bytes stream)
(let ((bits (byte->int bytes)))
(ieee-floats:decode-float32 bits))))
(defmacro define-offset-size (package prefix &rest name-offset-size)
`(progn
,@(loop for i in name-offset-size collect
`(progn
(alexandria:define-constant
,(alexandria:format-symbol package "~@:(+~a-~a-offset+~)" prefix (first i))
,(second i) :test #'=)
,(when (= (length i) 3)
`(alexandria:define-constant
,(alexandria:format-symbol package "~@:(+~a-~a-size+~)" prefix
(first i))
,(third i) :test #'=))))))
(defmacro define-parse-header-chunk ((name offset size object &optional (slot name)))
(alexandria:with-gensyms (bytes)
`(progn
(defgeneric ,(alexandria:format-symbol t "PARSE-~:@(~a~)" name) (,object stream))
(defmethod ,(alexandria:format-symbol t "PARSE-~:@(~a~)" name) ((object ,object) stream)
(file-position stream ,offset)
(let* ((,bytes (make-fresh-list ,size)))
(read-sequence ,bytes stream)
,(when (not (null slot))
`(setf (,slot object) ,bytes))
(values ,bytes object))))))
(defun read-list (stream size &key (offset nil))
(when offset
(file-position stream offset))
(let* ((bytes (misc-utils:make-fresh-list size)))
(read-sequence bytes stream)
bytes))
(defun read-array (stream size &key (offset nil))
(when offset
(file-position stream offset))
(let* ((bytes (misc-utils:make-array-frame size 0 '(unsigned-byte 8) t)))
(read-sequence bytes stream)
bytes))
;; sequence utils
(defun safe-elt (sequence index)
(and (>= index 0)
(< index (length sequence))
(elt sequence index)))
(defun safe-last-elt (sequence)
(safe-elt sequence (1- (length sequence))))
(defun safe-subseq (sequence start &optional (end nil))
(when sequence
(restart-case
(if (and (< start 0)
(< end 0))
(error 'conditions:out-of-bounds
:seq sequence
:idx end)
(let* ((actual-start (alexandria:clamp start
0
(length sequence)))
(actual-end (and end
(max actual-start
(min end
(length sequence))))))
(subseq sequence actual-start actual-end)))
(use-value (e) e)
(return-nil ()
nil)
(return-entire-sequence ()
sequence))))
(defgeneric sequence-empty-p (a))
(defmethod sequence-empty-p ((a vector))
(vector-empty-p a))
(defmethod sequence-empty-p ((a sequence))
(alexandria:emptyp a))
(defun vector-empty-p (v)
(declare (optimize (speed 3) (safety 0) (debug 0)))
(declare (vector v))
(= (length v) 0))
(defun random-num-filled-vector (size max)
(map-into (misc:make-array-frame size max (type-of max) t)
#'(lambda () (num:lcg-next-upto max))))
(definline random-elt (seq)
(elt seq (num:lcg-next-upto (length seq))))
(defun safe-random-elt (seq)
"note: values nil if (or (null seq) (= (length seq) 0))"
(and seq
(> (length seq) 0)
(elt seq (num:lcg-next-upto (length seq)))))
(defun make-fresh-list (size &optional (el nil))
(map-into (make-list size)
(if (functionp el)
el
#'(lambda () el))))
(defun seq->list (sequence)
(if (listp sequence)
(copy-list sequence)
(map-into (make-list (length sequence)) #'identity sequence)))
(defmacro *cat (type-return input)
`(reduce #'(lambda (a b) (concatenate ',type-return a b)) ,input))
(defun lcat (&rest v)
(declare (optimize (speed 3) (safety 1) (debug 0)))
(*cat list v))
(defun vcat (&rest v)
(declare (optimize (speed 3) (safety 1) (debug 0)))
(*cat vector v))
(defun fresh-list-insert@ (a v pos)
(declare (optimize (speed 3) (safety 1) (debug 0)))
(declare (list a))
(lcat (subseq a 0 pos)
(list v)
(subseq a pos)))
(defun fresh-list-subst@ (a v pos)
(declare (optimize (speed 3) (safety 1) (debug 0)))
(declare (list a))
(lcat (subseq a 0 pos)
(list v)
(subseq a (1+ pos))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-array-frame (size &optional (el nil) (type t) (simplep nil))
"All elements points to the same address/reference!"
(make-array size
:fill-pointer (if (not simplep) size nil)
:adjustable (if (not simplep) t nil)
:initial-element el
:element-type type)))
(defun make-fresh-array (size &optional (el nil) (type t) (simplep nil))
(let ((res (make-array size
:fill-pointer (if (not simplep) size nil)
:adjustable (if (not simplep) t nil)
:initial-element el
:element-type type)))
(map-into res #'(lambda (a) (setf a (cond
((functionp el)
(funcall el))
((arrayp el)
(alexandria:copy-array el))
((listp el)
(copy-list el))
(t
el))))
res)))
(defun list->array (the-list)
(make-array (length the-list)
:fill-pointer (length the-list)
:adjustable t
:initial-contents (copy-list the-list)))
(defun copy-list-into-array (from to)
(assert (= (length from) (length to)))
(loop
for i in from
for ct from 0 by 1 do
(setf (elt to ct) i))
to)
(defun array-slice (array start &optional (end nil))
(let* ((new-size (if end
(- end start)
(length array)))
(new-fill-pointer (cond
((array-has-fill-pointer-p array)
(if end
new-size
(fill-pointer array)))
(t
nil)))
(new-array (make-array new-size
:element-type (array-element-type array)
:fill-pointer new-fill-pointer
:initial-element (alexandria:first-elt array)
:adjustable (adjustable-array-p array)))
(end-iteration (or end
(length array))))
(loop
for index-from from start below end-iteration
for index-to from 0
do
(setf (elt new-array index-to)
(elt array index-from)))
new-array))
(defun list->simple-array (the-list start-type type)
(let ((res (make-array-frame (length the-list) start-type type t)))
(loop
for element in the-list
for i from 0 below (length the-list) do
(setf (elt res i) element))
res))
(defun permutation (li)
(let ((res-partial '())
(res '()))
(labels ((perm (start tail)
(let ((partial-tree '()))
(loop for i in start do
(loop for j in (set-difference tail i) do
(push (append i (list j)) partial-tree)))
(setf res-partial (reverse (copy-tree partial-tree))))))
(loop for ct in li do
(do ((start (list (list ct)) res-partial))
((null (set-difference li (first start)))
(progn
(setf res (append res res-partial))
(setf res-partial '())))
(perm start li))))
res))
(defun shuffle (sequence)
(loop for i from (1- (length sequence)) downto 1 do
(let ((rnd (num:lcg-next-upto (1+ i))))
(swap (elt sequence rnd) (elt sequence i))))
sequence)
(defun split-into-sublist (lst len)
(if (or (= len 0)
(< (length lst) len))
(if (null lst)
lst
(list lst))
(append (list (subseq lst 0 len)) (split-into-sublist (subseq lst len) len))))
(defun group-by (sequence &key (test #'=))
(let ((distinct '()))
(loop for i in sequence do
(pushnew i distinct :test test))
(loop for i in distinct collect
(remove-if-not #'(lambda (a) (funcall test a i)) sequence))))
(defgeneric delete@ (sequence position))
(defgeneric safe-delete@ (sequence position)
(:documentation "Return sequence if position is out of bound"))
(defmacro gen-delete@ ((sequence position) &body body)
`(if (and (>= ,position 0)
(< ,position (length ,sequence)))
,@body
(error 'conditions:out-of-bounds :seq sequence :idx position)))
(defmethod delete@ ((sequence list) position)
(gen-delete@
(sequence position)
(append (subseq sequence 0 position)
(and (/= position (- (length sequence) 1))
(subseq sequence (1+ position))))))
(defmethod delete@ ((sequence vector) position)
(gen-delete@
(sequence position)
(make-array (1- (length sequence))
:fill-pointer (1- (length sequence))
:adjustable t
:initial-contents (concatenate 'vector (subseq sequence 0 position)
(and (/= position (- (length sequence) 1))
(subseq sequence (1+ position)))))))
(defmethod safe-delete@ ((sequence sequence) position)
(restart-case
(delete@ sequence position)
(return-nil () nil)
(return-whole () sequence)
(new-index (i) (safe-delete@ sequence i))))
(defun safe-all-but-last-elt (sequence)
(handler-bind ((conditions:out-of-bounds
#'(lambda (c)
(declare (ignore c))
(invoke-restart 'return-nil))))
(safe-delete@ sequence (1- (length sequence)))))
(defgeneric remove-compact-remap-sequence (sequence predicate))
(defmethod remove-compact-remap-sequence ((sequence list) predicate)
(let ((nullified (loop
for i in sequence
for ct from 0 collect
(if (funcall predicate ct i)
nil
i)))
(mapping nil)
(results '()))
(loop
for i in nullified
for pos from 0 do
(when (not (null i))
(push i results)
(push (list pos (1- (length results))) mapping)))
(values (reverse results) mapping)))
(defmethod remove-compact-remap-sequence ((sequence vector) predicate)
(let ((nullified (loop for i from 0 below (length sequence) collect
(if (funcall predicate i (elt sequence i))
nil
(elt sequence i))))
(mapping nil)
(results (make-array-frame 0)))
(loop for i from 0 below (length nullified) do
(when (not (null (elt nullified i)))
(vector-push-extend (elt nullified i) results)
(push (list i (1- (length results))) mapping)))
(values results mapping)))
(defun remove-if-null (a)
(remove-if #'null a))
(defun remove-if-not-null (a)
(remove-if #'(lambda (i) (not (null i))) a))
(defun copy-multiply (from to length source-step copy-num)
(loop for ct from 0 below (* source-step length) by source-step
for ct2 from 0 below (* length source-step copy-num) by (* source-step copy-num) do
(loop for ct3 from 0 below (* source-step copy-num) by 1 do
(setf (elt to (+ ct2 ct3))
(elt from (+ ct (mod ct3 source-step))))))
to)
(defun all-but-last-elt (s)
(if s
(let ((length (length s)))
(if (> length 0)
(subseq s 0 (1- length))
s))
s))
(defgeneric intersperse (seq new-elt))
(defmethod intersperse ((seq list) new-elt)
(loop for (item . rest) on seq
if (null rest)
collect item
else collect item
and collect new-elt))
(defmethod intersperse ((seq sequence) new-elt)
(if (< (length seq) 2)
(copy-seq seq)
(let* ((len1 (length seq))
(len2 (1- (* 2 len1)))
(ret (typecase seq
(string
(make-string len2))
(vector
(make-fresh-array len2))))
(j 0))
(loop for i below len2 do
(if (oddp i)
(setf (elt ret i) new-elt)
(progn
(setf (elt ret i) (elt seq j))
(incf j))))
ret)))
;; iterations
(defmacro do-while (declaration return-form &body body)
"C-like \"do { ...} while (condition)\" statement: body is evaluated
even if exit condition is t at the very first iteration"
(alexandria:with-gensyms (first-iteration)
`(do ,(append (list `(,first-iteration t nil))
declaration)
,(append (list `(if ,first-iteration
nil
,(first return-form)))
(rest return-form))
,@body)))
(defmacro do-while* (declaration return-form &body body)
"C-like \"do { ...} while (condition)\" statement: body is evaluated
even if exit condition is t at the very first iteration"
(alexandria:with-gensyms (first-iteration)
`(do* ,(append (list `(,first-iteration t nil))
declaration)
,(append (list `(if ,first-iteration
nil
,(first return-form)))
(rest return-form))
,@body)))
;; cg vectors
(defmacro gen-vec-comp ((prefix-name comp-name index) &rest declarations)
(let ((name (format-fn-symbol t "~a-~a" prefix-name comp-name))
(set-name (format-fn-symbol t "%set-~a-~a" prefix-name comp-name))
(arg (format-fn-symbol t "v")))
`(progn
(defun ,set-name (vec value)
(setf (elt vec ,index) value))
(defsetf ,name ,set-name)
(defun ,name (,arg)
,@declarations
(elt ,arg ,index))
(define-compiler-macros ,name ,arg))))
;; cffi
(definline make-null-pointer ()
(cffi:null-pointer))
;; plugins, sort of
(defmacro with-load-forms-in-var ((special-var output-var file) &body body)
`(let* ((,special-var nil))
(load ,file)
(let ((,output-var ,special-var))
,@body)))
;;;; derived from local-time library
(alexandria:define-constant +unix-epoch+ (encode-universal-time 0 0 0 1 1 1970 0)
:test #'=)
(defun time-unix->universal (unix-timestamp)
"Return the UNIVERSAL-TIME corresponding to the TIMESTAMP"
;; universal time is seconds from 1900-01-01T00:00:00Z
;; unix timestamp is seconds from 1970-01-01T00:00:00Z
(+ unix-timestamp +unix-epoch+))
(defmacro gen-time-access (name pos)
`(defun ,(format-fn-symbol t "time-~a-of" name) (time-list)
(elt time-list ,pos)))
(defmacro gen-all-time-access (&rest name-pos)
`(progn
,@(loop for i in name-pos collect
`(gen-time-access ,(car i) ,(cdr i)))))
(gen-all-time-access (second . 0)
(minutes . 1)
(hour . 2)
(date . 3)
(month . 4)
(year . 5)
(day . 6)
(daylight-p . 7)
(zone . 8))
(defun year->timestamp (year)
(local-time:encode-timestamp 0
0
0
0
1
1
(truncate (max 0
(num:safe-parse-number year)))))
(defun current-year ()
(local-time:timestamp-year (db-utils:local-time-obj-now)))
(defun extract-year-from-timestamp (ts)
(local-time:timestamp-year ts))
(defun command-terminated-no-error-p (command-error-code)
(= command-error-code 0))
(defun format-time (local-time-object format-control-list)
(with-output-to-string (stream)
(local-time:format-timestring stream local-time-object :format format-control-list)))
;; threads
(defmacro with-lock ((lock) &body body)
`(bt:with-recursive-lock-held (,lock)
,@body))
(defmacro defun-w-lock (name parameters lock &body body)
(multiple-value-bind (remaining-forms declarations doc-string)
(alexandria:parse-body body :documentation t)
`(defun ,name ,parameters
,doc-string
,declarations
(with-lock (,lock)
,@remaining-forms))))
;; http
(defun get-url-content (url)
(drakma:http-request url
:want-stream t
:verify :required
:external-format-out :utf8))

134
src/modeline-window.lisp Normal file
View File

@ -0,0 +1,134 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2018 cage
;; 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/>.
(in-package :modeline-window)
(defclass modeline-window (wrapper-window)
((mapping-code->fn
:initform ()
:initarg :mapping-code->fn
:accessor mapping-code->fn)
(modeline-src
:initform ""
:initarg :modeline-text-src
:accessor modeline-src)
(modeline-text
:initform (_ "modeline")
:initarg :modeline-text
:accessor modeline-text)
(modeline-fg
:initform nil
:initarg :modeline-fg
:accessor modeline-fg)
(modeline-bg
:initform nil
:initarg :modeline-bg
:accessor modeline-bg)
(parsed-modeline
:initform ()
:initarg :parsed-modeline
:accessor parsed-modeline)))
(defgeneric expand-modeline-spec (object))
;; MODELINE := (FIELD | TEXT)*
;; FIELD := PERCENT KEY
;; KEY := [%abcdefghilmnopqrstuvzABCDEFGHILMNOPQRSTUVZ']
;; PERCENT := '%'
;; TEXT := (not percent)+
(defrule key
(or #\%
#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
#\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
#\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)
(:text t))
(defrule percent #\%
(:constant :key))
(defrule field (and percent key))
(defrule text (+ (not percent))
(:text t))
(defrule modeline (* (or field text)))
(defun call-function-mapped (win key mapping)
(let ((fn (cdr (assoc key mapping :test #'string=))))
(if fn
(funcall fn win)
(format nil "~~~a" key))))
(defmethod expand-modeline-spec ((object modeline-window))
(with-accessors ((modeline-src modeline-src)
(modeline-text modeline-text)
(modeline-bg modeline-bg)
(modeline-fg modeline-fg)
(mapping-code->fn mapping-code->fn)
(parsed-modeline parsed-modeline)) object
;; parsed is like '("foo" (:key "a") "bar" ...)
(let ((res (make-tui-string "")))
(loop for i in parsed-modeline do
(let ((executed (cond
((listp i)
(call-function-mapped object (lastcar i) mapping-code->fn))
(t
(make-tui-string i
:fgcolor modeline-fg
:bgcolor modeline-bg)))))
(setf res (cat-tui-string res executed))))
(setf res (text-ellipsize res (win-width-no-border object)))
(setf modeline-text res))))
(defun refresh-modeline-config (win key)
(with-accessors ((modeline-src modeline-src)
(modeline-text modeline-text)
(modeline-bg modeline-bg)
(modeline-fg modeline-fg)
(mapping-code->fn mapping-code->fn)
(parsed-modeline parsed-modeline)) win
(multiple-value-bind (bg fg)
(swconf:modeline-colors key)
(setf modeline-fg fg)
(setf modeline-bg bg)
(setf modeline-src (swconf:modeline-fmt key))
(setf parsed-modeline (parse 'modeline modeline-src))
(expand-modeline-spec win))
win))
(defmethod calculate ((object modeline-window) dt))
(defmethod draw :after ((object modeline-window))
(with-accessors ((modeline-bg modeline-bg)
(modeline-fg modeline-fg)
(modeline-text modeline-text)) object
(when-window-shown (object)
(let* ((line modeline-text)
(line-length (text-width line))
(max-width (win-width-no-border object)))
(when (< line-length max-width)
(setf line
(cat-tui-string line (build-string (- max-width line-length)))))
(print-text object line 1 (1- (win-height object)))))))
(defun add-modeline-char-expander (win code fn)
(assert (stringp code))
(assert (functionp fn))
(with-accessors ((mapping-code->fn mapping-code->fn)) win
(setf mapping-code->fn
(acons code fn mapping-code->fn))))

37
src/modules.lisp Normal file
View File

@ -0,0 +1,37 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/][http://www.gnu.org/licenses/]].
(in-package :modules)
(defun load-module (path)
(flet ((%load (file)
(load file :verbose nil :print nil)))
(let ((config-file (conditions:with-default-on-error (nil)
(get-config-file path)))
(data-file (conditions:with-default-on-error (nil)
(get-data-file path))))
(cond
(config-file
(%load config-file))
(data-file
(%load data-file))
(t
(error (_ "Unrecoverable error: file ~a not found in any of the directory ~a ~a ~a ~a")
+sys-data-dir+
+sys-conf-dir+
(home-datadir)
(home-confdir)))))))

620
src/mtree-utils.lisp Normal file
View File

@ -0,0 +1,620 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package mtree-utils)
;; tree := nil | node
;; node := (list atom node*)
;; example: '(1 (2) (3 (4) (5)))
(defgeneric leafp (object))
(defmethod leafp ((object cons))
(null (cdr object)))
(defun random-choose-leaf (tree)
(if (leafp tree)
(car tree)
(let ((children (cdr tree)))
(random-choose-leaf (misc:random-elt children)))))
(defun traverse-apply-tree (function tree &optional (args nil))
(append
(if (and (consp tree)
(not (null tree)))
(reverse
(append
(reverse (loop for i in (cdr tree) collect (traverse-apply-tree function i args)))
(list (apply function (append (list (car tree)) args)))))
nil)))
(defun traverse-napply-tree (function tree &optional (args nil))
(when (and (consp tree)
(not (null tree)))
(loop for i in (cdr tree) collect (traverse-napply-tree function i args))
(rplaca tree (apply function (append (list (car tree)) args)))))
(defun traverse-find-if-tree (tree item &key (test #'equal) (key #'identity))
(progn
(traverse-apply-tree #'(lambda (x) (if (funcall test item (funcall key x))
(return-from traverse-find-if-tree x)
nil))
tree)
nil))
(defun traverse-find-all-if-tree (tree item &key (test #'equal) (key #'identity))
(let ((res '()))
(traverse-apply-tree #'(lambda (x) (if (funcall test item (funcall key x))
(push x res)))
tree)
res))
(defun traverse-apply-tree-cdr (function tree &optional (args nil))
(append
(if (and (consp tree)
(not (null tree)))
(append
(list (apply function (append (list tree) args)))
(loop for i in (cdr tree) by #'cdr collect (traverse-apply-tree-cdr function i args)))
nil)))
(defun traverse-nadd-child (tree node child &key (test #'equal) (key #'identity))
(traverse-apply-tree-cdr
#'(lambda (x) (when (funcall test (funcall key (car x)) node)
(progn
(rplacd x (append (list (list child)) (cdr x)))
(rplaca x (car x)))))
tree)
tree)
(defun nappend-child (tree child)
(rplacd tree (concatenate 'list (cdr tree) (list (list child)))))
(defun traverse-ndelete-child (tree node &key (test #'equal) (key #'identity))
(traverse-apply-tree-cdr
#'(lambda (x) (loop
for i in (cdr x)
for ct = 0 then (1+ ct)
do
(if (funcall test (funcall key (car i)) node)
(rplacd x (misc-utils:safe-delete@ (cdr x) ct)))))
tree)
tree)
(defmacro %navigate (tree path)
(if path
`(nth ,(first path) (%navigate ,tree ,(rest path)))
tree))
(defmacro navigate (tree path)
`(%navigate ,tree ,(reverse path)))
(defun init-children ()
(misc:make-fresh-array 0 nil t t))
(defclass m-tree ()
((data
:initform nil
:initarg :data
:accessor data)
(parent
:initform nil
:initarg :parent
:accessor parent)
(children
:initform (init-children)
:initarg :children
:accessor children)))
(defmethod marshal:class-persistant-slots ((object m-tree))
'(data parent children))
(defgeneric pprint-tree (object stream &optional level parent-length other-data))
(defgeneric add-child (object child &optional child-pos))
(defgeneric child-data-pushnew (object child &key key test))
(defgeneric graft-branch (rootstock scion &key key test overwrite-rootstock-data-p))
(defgeneric add-children (object children))
(defgeneric add-children* (object &rest children))
(defgeneric find-child (object to-find &key compare))
(defgeneric find-child-if (object predicate))
(defgeneric rootp (object))
(defgeneric top-down-visit (object function &optional args))
(defgeneric bottom-up-visit (object function &optional args))
(defgeneric remove-all-children (object))
(defgeneric remove-child (object needle &key key test))
(defgeneric remove-child-if (object predicate))
(defgeneric count-leaves (object))
(defgeneric count-nodes (object))
(defgeneric mtree-equal (tree-1 tree-2 &key key-fn compare-fn))
(defgeneric root-node (object))
(defgeneric single-node-tree-p (object))
(defgeneric tree->text-lines (object &key
last-child-char line-char child-char arrow-char
print-data
print-data-fn))
(defgeneric tree->annotated-lines (object &key
last-child-char line-char child-char arrow-char
print-data
print-data-fn))
(defparameter *use-pprint-tree* nil)
(defmethod print-object ((object m-tree) stream)
(if *use-pprint-tree*
(pprint-tree object stream)
(format stream "[data ~a children ~a]" (data object) (children object))))
(defmethod pprint-tree ((object m-tree) stream &optional (level 0) (parent-length 0)
(other-data nil))
(declare (ignore other-data))
(labels ((indent (level &optional (char " ")) (make-list level :initial-element char)))
(with-accessors ((data data) (children children)) object
(let ((data-length (+
(do ((parent (parent object) (parent parent))
(data-length 0))
((not parent) data-length)
(incf data-length (length (format nil "~a" (data parent)))))
(length (format nil "~a" data)))))
(format stream "~{~a~}~a" (indent (+ level parent-length))
data)
(if (leafp object)
(format stream "~%")
(progn
(pprint-tree (elt children 0) stream 1)
(map nil #'(lambda (c) (pprint-tree c stream (1+ level) data-length))
(subseq children 1))))))))
(defmethod clone ((object m-tree))
(make-instance 'm-tree :data (data object) :parent (parent object)
:children (alexandria:copy-array (children object))))
(defmethod add-child ((object m-tree) (child m-tree)
&optional (child-pos (length (children object))))
(with-accessors ((children children)) object
(setf (parent child) object)
(if (and child-pos
(< child-pos (length children))
(>= child-pos 0))
(setf children
(let ((res (misc:make-fresh-array (1+ (length children))
nil (type-of child) t)))
(loop for i from 0 below child-pos do
(setf (elt res i) (elt children i)))
(setf (elt res child-pos) child)
(loop for i from (1+ child-pos) below (length res) do
(setf (elt res i) (elt children (1- i))))
res))
(setf children
(let ((res (misc:make-fresh-array (1+ (length children))
nil (type-of child) t)))
(loop for i from 0 below (1- (length res)) do
(setf (elt res i) (elt children i)))
(setf (elt res (1- (length res))) child)
res)))
(values object child)))
(defmethod child-data-pushnew ((object m-tree) (child m-tree)
&key (key #'identity) (test #'eq))
"Push a child if there is no siblings with the same data under
`test' or `key' functions"
(let ((old-data (map 'list (lambda (a) (funcall key (data a)))
(children object)))
(new-datum (funcall key (data child))))
(when (not (find new-datum old-data :test test))
(add-child object child))
object))
(defmacro do-children ((child node) &body body)
`(loop for ,child across (children ,node) do
,@body))
(defmacro do-children-from-end ((child node) &body body)
`(loop for ,child across (reverse (children ,node)) do
,@body))
(defmethod graft-branch ((rootstock m-tree) (scion m-tree)
&key
(key #'identity) (test #'eq)
(overwrite-rootstock-data-p t))
"Graft a tree with a single branch (scion) to a tree (rootstock).
They have to share a common prefix of a list one node
(i.e '(funcall test (key (data rootstock)) (key (data scion)))' is
non-nil)
If `overwrite-rootstock-data-p' is non-nil any the node of the scion that is equals
under `test' to the any of the rootstock overwrite it.
Assume this function modify rootstock.
Examples given:
a a a
/ \ + | -> / \
b c c b c
\ | / \
d e e d
a a a------+
/ \ + | -> / \ |
b c d b c d
\ | \ |
d e d e
a a a
/ \ + | -> / \
b c c b c
| /
e e
a b a
/ \ + | -> / \
b c c b c
\ | \
d e d
"
(labels ((extract-data (a)
(funcall key (data a)))
(test-data (a b)
(funcall test
(extract-data a)
(extract-data b)))
(twins-sibling (children-rootstock children-scion)
(loop for child-rootstock across children-rootstock do
(loop for child-scion across children-scion do
(when (test-data child-rootstock child-scion)
(return-from twins-sibling
(values child-rootstock child-scion)))))
nil))
(with-accessors ((parent-rootstock parent)
(children-rootstock children)) rootstock
(if (test-data rootstock scion)
(progn
(when overwrite-rootstock-data-p
(setf (data rootstock)
(data scion)))
(cond
((misc:vector-empty-p children-rootstock)
(add-children rootstock (children scion)))
(t
(multiple-value-bind (twin-rootstock twin-scion)
(twins-sibling children-rootstock
(children scion))
(if twin-rootstock
(graft-branch twin-rootstock twin-scion :test test :key key)
(add-children rootstock (children scion)))))))
(when (not (rootp rootstock))
(add-child parent-rootstock scion)))
rootstock)))
(defmethod add-children ((object m-tree) (children list))
(loop for i in children do
(add-child object i))
object)
(defmethod add-children ((object m-tree) (children vector))
(loop for i across children do
(add-child object i))
object)
(defmethod add-children* ((object m-tree) &rest children)
(add-children object children))
(defmethod find-child ((object m-tree) to-find &key (compare #'equalp))
(with-accessors ((data data) (children children)) object
(if (funcall compare data to-find)
object
(if (leafp object)
nil
(find-if-not #'null
(map 'vector #'(lambda (c)
(find-child c to-find :compare compare))
children))))))
(defmethod find-child-if ((object m-tree) predicate)
(let ((res '()))
(labels ((%find-child-if (object predicate)
(when (funcall predicate object)
(push object res))
(do-children (child object)
(%find-child-if child predicate))))
(%find-child-if object predicate)
res)))
(defmethod leafp ((object m-tree))
(= (length (children object)) 0))
(defmethod rootp ((object m-tree))
(null (parent object)))
(defmethod top-down-visit ((node m-tree) function &optional (args nil))
(apply function (concatenate 'list (list node) args))
(loop for c across (children node) do
(top-down-visit c function args)))
(defmethod bottom-up-visit ((node m-tree) function &optional (args nil))
(loop for c across (children node) do
(bottom-up-visit c function args))
(apply function (concatenate 'list (list node) args)))
(defmethod remove-all-children ((object m-tree))
(setf (children object) (init-children)))
(defmethod remove-child ((object m-tree) (needle m-tree) &key
(key #'identity)
(test #'eq))
(with-accessors ((children children)) object
(if (leafp object)
nil
(loop for i fixnum from 0 below (length children) do
(if (funcall test (funcall key needle) (funcall key (elt children i)))
(progn
(setf children
(concatenate `(vector ,(array-element-type children)
,(1- (length children)))
(subseq children 0 i)
(subseq children (1+ i))))
(return-from remove-child t))
(remove-child (elt children i) needle :key key :test test))))))
(defmethod remove-child ((object m-tree) needle &key
(key #'identity)
(test #'eq))
(with-accessors ((children children)) object
(if (leafp object)
nil
(loop for i fixnum from 0 below (length children) do
(if (funcall test (funcall key needle) (funcall key (elt children i)))
(progn
(setf children
(concatenate `(vector ,(array-element-type children)
,(1- (length children)))
(subseq children 0 i)
(subseq children (1+ i))))
(return-from remove-child t))
(remove-child (elt children i) needle :key key :test test))))))
(defmethod remove-child-if ((object m-tree) predicate)
(top-down-visit object
#'(lambda (n)
(with-accessors ((children children)) n
(setf children (delete-if predicate children))))))
(defmethod count-leaves ((object m-tree))
(let ((results 0))
(top-down-visit object #'(lambda (n)
(when (leafp n)
(incf results))))
results))
(defmethod count-nodes ((object m-tree))
(let ((results 0))
(top-down-visit object #'(lambda (n)
(declare (ignore n))
(incf results)))
results))
(defmethod mtree-equal ((tree-1 m-tree) (tree-2 m-tree)
&key
(key-fn #'identity)
(compare-fn #'eq))
(labels ((%mtree-equal (tree-a tree-b)
(with-accessors ((children-a children)) tree-a
(with-accessors ((children-b children)) tree-b
(let ((value-a (funcall key-fn (data tree-a)))
(value-b (funcall key-fn (data tree-b))))
(if (funcall compare-fn value-a value-b)
(if (= (length children-a)
(length children-b))
(progn
(loop
for child-a across children-a
for child-b across children-b do
(%mtree-equal child-a
child-b))
t)
(return-from mtree-equal nil))
(return-from mtree-equal nil)))))))
(%mtree-equal tree-1 tree-2)))
(defmethod root-node ((object m-tree))
(if (rootp object)
object
(root-node (parent object))))
(defmethod single-node-tree-p ((object m-tree))
(and (rootp object)
(leafp object)))
(defun make-node (data &optional (parent nil))
(make-instance 'm-tree :data data :parent parent))
(defclass sorted-m-tree (m-tree)
((compare-fn
:initform #'<
:initarg :compare-fn
:accessor compare-fn
:documentation "The predicate for children comparison. Default #'<")
(key-fn
:initform #'identity
:initarg :key-fn
:accessor key-fn
:documentation "The function to extract the values from slot
`data' from each children. Default #'identity"))
(:documentation "A tree that keep its children sorted"))
(misc:definline sort-children (tree)
(with-accessors ((children children)
(compare-fn compare-fn)
(key-fn key-fn)) tree
(setf children (num:shellsort children compare-fn
:key (lambda (a) (funcall key-fn (data a)))))))
(defmethod initialize-instance :after ((object sorted-m-tree) &key &allow-other-keys)
(sort-children object)
object)
(defmethod add-child :after ((object sorted-m-tree) (child m-tree)
&optional (child-pos (length (children object))))
(declare (ignore child child-pos))
(sort-children object))
(alexandria:define-constant +tree-arrow-char+ #\BLACK_RIGHT-POINTING_ISOSCELES_RIGHT_TRIANGLE
:test #'char=)
(defmethod tree->text-lines ((object m-tree)
&key
(last-child-char (string #\╰))
(line-char (string #\│))
(child-char (string #\├))
(spacer-child (string #\─))
(arrow-char (format nil "~c " +tree-arrow-char+))
(print-data nil)
(print-data-fn #'to-s))
(let ((res ())
(indent-step 1))
(labels ((last-child-p (tree pos)
(if (rootp tree)
t
(>= pos (1- (length (children (parent tree)))))))
(%print (node indent-level child-pos empty-levels)
(let ((line "")
(data (if print-data
(funcall print-data-fn (data node))
"")))
(flet ((cat-line (&rest chunks)
(setf line
(reduce #'strcat chunks :initial-value line))))
(loop for i from 1 below indent-level do
(if (find i empty-levels :test #'=)
(cat-line " ")
(cat-line line-char))
(loop repeat indent-step do
(cat-line " ")))
(cond
((rootp node)
(cat-line data))
((last-child-p node child-pos)
(push indent-level empty-levels)
(cat-line last-child-char spacer-child arrow-char data))
(t
(cat-line child-char spacer-child arrow-char data))))
(values line empty-levels)))
(visit (tree indent-level child-pos empty-levels)
(multiple-value-bind (line new-empty-levels)
(%print tree indent-level child-pos empty-levels)
(push line res)
(loop
for node across (children tree)
for ct-pos from 0
do
(visit node (1+ indent-level) ct-pos new-empty-levels)))))
(visit object 0 0 ())
(reverse res))))
(defmethod tree->annotated-lines ((object m-tree)
&key
(last-child-char
(string #\BOX_DRAWINGS_LIGHT_ARC_UP_AND_RIGHT))
(line-char
(string #\BOX_DRAWINGS_LIGHT_VERTICAL))
(child-char
(string #\BOX_DRAWINGS_LIGHT_VERTICAL_AND_RIGHT))
(spacer-child (string #\BOX_DRAWINGS_LIGHT_HORIZONTAL))
(arrow-char "> ")
(print-data nil)
(print-data-fn #'to-s))
(let ((res ())
(indent-step 1))
(labels ((last-child-p (tree pos)
(if (rootp tree)
t
(>= pos (1- (length (children (parent tree)))))))
(%print (node indent-level child-pos empty-levels)
(let ((line ())
(data (if print-data
(funcall print-data-fn (data node))
"")))
(labels ((append-build-element (&rest chunks)
(setf line
(reduce #'append
(mapcar (lambda (a) (list a)) chunks)
:initial-value line)))
(cat-line (&rest chunks)
(if line
(let* ((last-element (alexandria:last-elt line))
(new-element (list (annotated-text-value last-element)))
(to-concat (strcat* (append new-element
chunks))))
(setf (alexandria:last-elt line) (cons :branch to-concat)))
(setf line (list (cons :a (strcat* chunks))))))
(build-element (trunk-char data node)
(append-build-element (cons :branch
(strcat trunk-char
spacer-child))
(cons :arrow arrow-char)
(if (leafp node)
(cons :data-leaf data)
(cons :data data)))))
(loop for i from 1 below indent-level do
(if (find i empty-levels :test #'=)
(cat-line " ")
(append-build-element (cons :d line-char)))
(loop repeat indent-step do
(cat-line " ")))
(cond
((rootp node)
(append-build-element (cons :data data)))
((last-child-p node child-pos)
(push indent-level empty-levels)
(build-element last-child-char data node))
(t
(build-element child-char data node))))
(values line empty-levels)))
(visit (tree indent-level child-pos empty-levels)
(multiple-value-bind (line new-empty-levels)
(%print tree indent-level child-pos empty-levels)
(push line res)
(loop
for node across (children tree)
for ct-pos from 0
do
(visit node (1+ indent-level) ct-pos new-empty-levels)))))
(visit object 0 0 ())
(reverse res))))

101
src/notify-window.lisp Normal file
View File

@ -0,0 +1,101 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/][http://www.gnu.org/licenses/]].
(in-package :notify-window)
(define-constant +notify-win-background-color+ '(:yellow :blue)
:test #'equalp)
(define-constant +notify-win-background+ (make-instance 'complex-char
:simple-char #\Space
:color-pair +notify-win-background-color+
:attributes nil)
:test #'complex-char=)
(defclass notify-window (wrapper-window)
((life
:initform 10.0
:initarg :life
:accessor life)
(pending
:initform 0
:initarg :pending
:accessor pending)))
(defun notify-window-p (thing)
(typep thing 'notify-window))
(defmethod refresh-config :after ((object notify-window))
(refresh-config-colors object swconf:+key-notify-window+))
(defmethod calculate ((object notify-window) dt)
(with-accessors ((life life)) object
(when (< life 0.0)
(let ((remove-win-event (make-instance 'program-events:remove-notify-user-event
:payload object)))
(win-close object)
(program-events:push-event remove-win-event)))
(decf (life object) dt)))
(defmethod draw ((object notify-window))
(declare (ignore object)))
(defgeneric draw-pending (object))
(defmethod draw-pending ((object notify-window))
(with-accessors ((pending pending)) object
(when (> pending 0)
(print-text object
(format nil (n_ "~a pending"
"~a pending"
pending)
pending)
2
(1- (win-height object))))))
(defun force-error-colors (window)
(with-croatoan-window (croatoan-window window)
(setf (background croatoan-window)
(tui:make-background :red))
(setf (bgcolor croatoan-window) :red)
(setf (fgcolor croatoan-window) :yellow))
window)
(defun make-notification-window (message life &key (pending 0) (hidep nil) (notify-error nil))
(let* ((low-level-window (make-croatoan-window :draw-border t))
(high-level-window (make-instance 'notify-window
:life life
:pending pending
:croatoan-window low-level-window)))
(refresh-config high-level-window)
(when notify-error
(force-error-colors high-level-window))
(let ((win-w (truncate (* 1/6 (win-width *main-window*))))
(win-h (truncate (* 1/8 (win-height *main-window*)))))
(win-resize high-level-window win-w win-h)
;; add-flush-left-text will expand window's height if needed
(add-flush-left-text high-level-window
message 0
:has-border-p t
:attributes (attribute-bold))
(win-raise-to-top high-level-window)
(win-move high-level-window 1 1)
(win-box high-level-window)
(when hidep
(win-hide high-level-window))
(mtree:add-child specials:*main-window* high-level-window)
high-level-window)))

288
src/num-utils.lisp Normal file
View File

@ -0,0 +1,288 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/][http://www.gnu.org/licenses/]].
;; NOTE: any random function are not for crypto use!
(in-package :num-utils)
(defun safe-parse-number (maybe-number &key (fix-fn #'(lambda (e) (declare (ignore e)) nil)))
(handler-bind ((error
(lambda(e)
(return-from safe-parse-number (funcall fix-fn e)))))
(if (or (not (stringp maybe-number))
(string= maybe-number "-"))
(error "Paring a non string element")
(parse-number:parse-number maybe-number))))
(defun parse-number-default (maybe-number default)
(safe-parse-number maybe-number
:fix-fn (lambda (e) (declare (ignore e)) default)))
(defun find-min-max (function the-list)
(restart-case
(reduce #'(lambda (a b) (if (funcall function a b) a b)) the-list)
(use-value (e) e)))
(defun find-min (the-list)
(find-min-max #'< the-list))
(defun find-max (the-list)
(find-min-max #'> the-list))
(defgeneric round-all (object &key rounding-function))
(defmethod round-all ((object list) &key (rounding-function #'round))
(mapcar #'(lambda (n) (funcall rounding-function n)) object))
(defmethod round-all ((object number) &key (rounding-function #'round))
(funcall rounding-function object))
(defmethod round-all ((object vector) &key (rounding-function #'round))
(map (type-of object) #'(lambda (n) (funcall rounding-function n)) object))
(defun fract (n)
(multiple-value-bind (int frac)
(truncate n)
(declare (ignore int))
frac))
(defun sign (n)
(if (< n 0)
-1
1))
(defun count-digit (number &optional (so-far 1))
(let ((reduced (truncate (/ number 10))))
(if (= reduced 0)
so-far
(count-digit reduced (1+ so-far)))))
(alexandria:define-constant +fnv-prime-32+ 16777619 :test #'=)
(alexandria:define-constant +fnv-offset-basis-32+ 2166136261 :test #'=)
(defun fnv-hash-32 (octects)
(let ((hash +fnv-offset-basis-32+))
(loop for i across octects do
(setf hash (boole boole-xor hash i))
(setf hash (ldb (byte 32 0) (* hash +fnv-prime-32+))))
hash))
(defun string-fnv-hash-32 (s)
(fnv-hash-32 (map 'vector #'char-code (coerce s 'list))))
(alexandria:define-constant +fnv-prime-256+
374144419156711147060143317175368453031918731002211 :test #'=)
(alexandria:define-constant +fnv-offset-basis-256+
100029257958052580907070968620625704837092796014241193945225284501741471925557
:test #'=)
(defun fnv-hash-256 (octects)
(let ((hash +fnv-offset-basis-256+))
(loop for i across octects do
(setf hash (boole boole-xor hash i))
(setf hash (ldb (byte 256 0) (* hash +fnv-prime-256+))))
hash))
(defun string-fnv-hash-256 (s)
(fnv-hash-256 (map 'vector #'char-code (coerce s 'list))))
(alexandria:define-constant +lcg-modulo-pow+ 64 :test #'=)
(alexandria:define-constant +lcg-good-bit-starts+ 32 :test #'=)
(alexandria:define-constant +lcg-good-bit-size+ 32 :test #'=)
(alexandria:define-constant +lcg-modulo+ 18446744073709551616 :test #'=)
(alexandria:define-constant +lcg-max+ 4294967295 :test #'=)
(alexandria:define-constant +lcg-a+ 3935559000370003845 :test #'=)
(alexandria:define-constant +lcg-c+ 2691343689449507681 :test #'=)
(defparameter *lcg-seed* 0)
(defun lcg-set-seed (&optional (seed (get-universal-time)))
(setf *lcg-seed* seed))
(defun lcg-next ()
(setf *lcg-seed*
(ldb (byte +lcg-modulo-pow+ 0)
(+ (* +lcg-a+ *lcg-seed*) +lcg-c+)))
(ldb (byte +lcg-good-bit-size+ +lcg-good-bit-starts+) *lcg-seed*))
(defun lcg-next01 ()
(coerce (/ (lcg-next) +lcg-max+)
'float))
(defgeneric lcg-next-upto (max))
(defmethod lcg-next-upto ((max float))
(multiple-value-bind (integer-part remainder)
(truncate max)
(coerce (+ (* (lcg-next01) integer-part) (* (lcg-next01) remainder))
'float)))
(defmethod lcg-next-upto ((max integer))
(mod (lcg-next) max))
(defmethod lcg-next-upto ((max ratio))
(lcg-next-upto (float max)))
(defun lcg-next-in-range (from to)
(+ (lcg-next-upto (- to from)) from))
(defun lcg-next-in-range* (range)
"range is a cons cell (from . to)"
(lcg-next-in-range (car range) (cdr range)))
(defmacro with-lcg-seed ((&optional (seed `(get-universal-time))) &body body)
`(let ((*lcg-seed* ,seed))
,@body))
(defun get-random-float-sign ()
(declare (optimize (speed 3) (debug 0) (safety 0)))
(if (= (the integer (lcg-next-upto 2)) 0) 1.0 -1.0))
(defgeneric shellsort (sequence predicate &key key)
(:documentation "Note: makes a new sequence"))
(defmethod shellsort ((sequence list) predicate &key (key #'identity))
(call-next-method (copy-list sequence)
predicate
:key key))
(defmethod shellsort ((sequence vector) predicate &key (key #'identity))
(call-next-method (alexandria:copy-array sequence)
predicate
:key key))
(defun tokuda-sequence (n)
(do ((k 1 (1+ k))
(h 1.0 (+ (* 2.25 h) 1.0))
(res '()))
((not (< h n)) res)
(push (ceiling h) res)))
(defmethod shellsort (sequence predicate &key (key #'identity))
(loop for gap in (tokuda-sequence (length sequence)) do
(loop for i from gap below (length sequence) by 1 do
(let ((tmp (elt sequence i)))
(do ((j i (- j gap)))
((not (and (>= j gap)
(not (funcall predicate
(funcall key (elt sequence (- j gap)))
(funcall key tmp)))))
(setf (elt sequence j) tmp))
(let ((swp (elt sequence (- j gap))))
(setf (elt sequence j) swp))))))
sequence)
(defun multisort (bag fns)
(shellsort bag
#'(lambda (a b)
(let ((partial (loop named outer for fn in fns do
(cond
((< (funcall fn a b) 0)
(return-from outer t))
((> (funcall fn a b) 0)
(return-from outer nil))))))
partial))))
(defun multisort* (bag &rest fns)
(multisort bag fns))
(defmacro gen-multisort-test (fn-< fn-> fn-access)
(alexandria:with-gensyms (a b access-a access-b)
`(lambda (,a ,b)
(let ((,access-a (funcall (misc:fn-delay ,fn-access) ,a))
(,access-b (funcall (misc:fn-delay ,fn-access) ,b)))
(cond
((funcall (misc:fn-delay ,fn-<) ,access-a ,access-b)
-1)
((funcall (misc:fn-delay ,fn->) ,access-a ,access-b)
1)
(t 0))))))
(defparameter *default-epsilon* 1e-7)
(defmacro with-epsilon ((epsilon) &body body)
`(let ((*default-epsilon* ,epsilon))
,@body))
(defun add-epsilon-rel (v &optional (epsilon *default-epsilon*))
(+ v (* epsilon v)))
(defun epsilon<= (a b &optional (epsilon *default-epsilon*))
(or (<= a b)
(epsilon= a b epsilon)))
(defun epsilon>= (a b &optional (epsilon *default-epsilon*))
(or (>= a b)
(epsilon= a b epsilon)))
(defun epsilon= (a b &optional (epsilon *default-epsilon*))
(and (<= (- b epsilon) a (+ b epsilon))))
(defun binary-search (sequence value-looking-for
&key
(compare-fn #'<)
(equal-fn #'=)
(left-limit 0)
(right-limit (1- (length sequence))))
"Perform a binary search on `sequence' looking for
`value-looking-for' using `equal-fn' as equality test function and
`compare-fn' as comparing function. Values position where the value
has been found in `sequence' or nil. `sequence' must be sorted in
ascending order using the same predicate as `compare-fn'. Recursive."
(when (not (misc:sequence-empty-p sequence))
(assert (< right-limit (length sequence)))
(assert (>= left-limit 0))
(assert (< left-limit (length sequence)))
(flet ((equals (element)
(funcall equal-fn element value-looking-for))
(less-than (a b)
(funcall compare-fn a b)))
(cond
((>= left-limit right-limit)
(if (equals (elt sequence left-limit))
left-limit
nil))
(t
(let* ((midpoint (floor (+ left-limit
(/ (- right-limit left-limit)
2))))
(mid-point-value (elt sequence midpoint)))
(cond
((equals mid-point-value)
midpoint)
((less-than value-looking-for mid-point-value)
(binary-search sequence
value-looking-for
:compare-fn compare-fn
:equal-fn equal-fn
:left-limit left-limit
:right-limit (1- midpoint)))
(t
(binary-search sequence
value-looking-for
:compare-fn compare-fn
:equal-fn equal-fn
:left-limit (1+ midpoint)
:right-limit right-limit)))))))))

127
src/open-attach-window.lisp Normal file
View File

@ -0,0 +1,127 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :open-attach-window)
(defclass open-attach-window (focus-marked-window
simple-line-navigation-window
title-window
border-window)
((status-id
:initform nil
:initarg :status-id
:accessor status-id)))
(defmethod refresh-config :after ((object open-attach-window))
(with-accessors ((croatoan-window croatoan-window)
(selected-line-bg selected-line-bg)
(selected-line-fg selected-line-fg)) object
(let* ((theme-style (swconf:form-style swconf:+key-open-attach-window+))
(fg (swconf:foreground theme-style))
(bg (swconf:background theme-style))
(selected-fg (swconf:selected-foreground theme-style))
(selected-bg (swconf:selected-background theme-style))
(win-w (truncate (/ (win-width specials:*main-window*) 2)))
(win-h (truncate (/ (win-height specials:*main-window*) 2)))
(x (truncate (- (/ (win-width specials:*main-window*) 2)
(/ win-w 2))))
(y (truncate (- (/ (win-height specials:*main-window*) 2)
(/ win-h 2)))))
(setf (background croatoan-window)
(tui:make-background bg))
(setf (bgcolor croatoan-window) bg)
(setf (fgcolor croatoan-window) fg)
(setf selected-line-fg selected-fg)
(setf selected-line-bg selected-bg)
(win-resize object win-w win-h)
(win-move object x y)
object)))
(defmethod resync-rows-db ((object open-attach-window) &key
(redraw t)
(suggested-message-index nil))
(with-accessors ((rows rows)
(status-id status-id)
(selected-line-bg selected-line-bg)
(selected-line-fg selected-line-fg)) object
(flet ((make-rows (attach-names bg fg)
(mapcar (lambda (name)
(make-instance 'line
:normal-text name
:selected-text name
:normal-bg bg
:normal-fg fg
:selected-bg fg
:selected-fg bg))
attach-names)))
(let ((attach-names (db:all-attachments-urls-to-status status-id)))
(with-croatoan-window (croatoan-window object)
(setf rows (make-rows attach-names
selected-line-bg
selected-line-fg))
(when suggested-message-index
(select-row object suggested-message-index))
(when redraw
(draw object)))))))
(defun init (status-id)
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
(setf *open-attach-window*
(make-instance 'open-attach-window
:title (_ "Attachments")
:status-id status-id
:single-row-height 1
:uses-border-p t
:keybindings keybindings:*open-attach-keymap*
:croatoan-window low-level-window))
(refresh-config *open-attach-window*)
(resync-rows-db *open-attach-window* :redraw nil)
(when (rows *open-attach-window*)
(select-row *open-attach-window* 0))
(draw *open-attach-window*)
*open-attach-window*))
(defun get-extension (file)
(multiple-value-bind (matchedp res)
(cl-ppcre:scan-to-strings "(?i)[a-z0-9]\(\\.[^.]+)(\\?.+)$" file)
(when matchedp
(first-elt res))))
(defun open-attachment (url)
(flet ((add-extension (cached-value)
(strcat (to-s cached-value) (get-extension url))))
(let ((cached (db:cache-get-value url)))
(if (not cached)
(let* ((cached-file-name (add-extension (db:cache-put url)))
(cached-output-file (os-utils:cached-file-path cached-file-name))
(stream (get-url-content url)))
(fs:create-file cached-output-file :skip-if-exists t)
(with-open-file (out-stream
cached-output-file
:element-type '(unsigned-byte 8)
:if-does-not-exist :error
:if-exists :supersede
:direction :output)
(loop for byte = (read-byte stream nil nil) while byte do
(write-byte byte out-stream)))
(open-attachment url))
(let ((cached-file (os-utils:cached-file-path (add-extension cached))))
(if (or (not (fs:file-exists-p cached-file))
(<= (fs:file-size cached-file) 0))
(progn
(db:cache-invalidate url)
(open-attachment url))
(os-utils:xdg-open cached-file)))))))

87
src/os-utils.lisp Normal file
View File

@ -0,0 +1,87 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :os-utils)
(alexandria:define-constant +proc-file-system+
(concatenate 'string filesystem-utils:*directory-sep*
"proc")
:test #'string=)
(alexandria:define-constant +proc-cpuinfo+
(concatenate 'string +proc-file-system+ filesystem-utils:*directory-sep*
"cpuinfo")
:test #'string=)
(declaim (ftype (function () fixnum) cpu-number))
(defun cpu-number ()
#+windows (the fixnum 1)
#-windows
(with-open-file (stream +proc-cpuinfo+ :direction :input
:if-does-not-exist :error)
(do ((line (read-line stream nil nil) (read-line stream nil nil))
(cpu-count 0))
((not line) (the fixnum cpu-count))
(when (cl-ppcre:scan "^processor" line)
(incf cpu-count)))))
(defun xdg-open (file)
(uiop:launch-program (format nil "xdg-open '~a'" file)
:output nil))
(defun getenv (name)
(nix:getenv name))
(defun default-temp-dir ()
(or (os-utils:getenv "TMPDIR")
"/tmp/"))
(defun external-editor ()
(let ((error-message
(_ "No editor found, please configure the 'editor' directive in your configuration file"))
(editor (or (swconf:external-editor)
(getenv "EDITOR"))))
(if (null editor)
(error error-message)
(let ((space (cl-ppcre:scan "\\s" editor)))
(if space
(let ((exe (subseq editor 0 space))
(args (subseq editor (1+ space))))
(values exe args))
(values editor nil))))))
(defun open-with-editor (file)
(multiple-value-bind (exe args)
(external-editor)
(sb-ext:run-program exe
(append (list args)
(list file))
:search t
:wait t
:input t
:output t
:error t)))
(defun exit-program (&optional (exit-code 0))
(uiop:quit exit-code))
(defun user-cache-dir (&rest more)
(fs:pathname->namestring (apply #'uiop:xdg-cache-home
(append (list +program-name+) more))))
(defun cached-file-path (filename)
(text-utils:strcat (user-cache-dir) fs:*directory-sep* filename))

1927
src/package.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

127
src/point-tracker.lisp Normal file
View File

@ -0,0 +1,127 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2018 cage
;; 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/>.
(in-package :point-tracker)
(defclass point-tracker ()
((point-position
:initform 0
:initarg :point-position
:accessor point-position)
(point-fg
:initform :white
:initarg :point-fg
:accessor point-fg)
(point-bg
:initform :white
:initarg :point-bg
:accessor point-bg)
(prompt
:initform "> "
:initarg :prompt
:accessor prompt)))
(defmethod initialize-instance :after ((object point-tracker) &key &allow-other-keys)
(with-accessors ((point-position point-position)
(prompt prompt)) object
(setf point-position (length prompt))))
(defgeneric no-prompt-point-pos (object))
(defgeneric move-point-left (object &key offset))
(defgeneric move-point-right (object max &key offset))
(defgeneric move-point (object to max))
(defgeneric move-point-to-end (object text))
(defgeneric move-point-to-start (object))
(defgeneric insert-at-point (object thing text))
(defgeneric delete-at-point (object text &key direction))
(defmethod no-prompt-point-pos ((object point-tracker))
(- (point-position object)
(length (prompt object))))
(defmethod move-point-left ((object point-tracker) &key (offset 1))
(with-accessors ((point-position point-position)
(prompt prompt)) object
(setf point-position
(max (length prompt)
(- point-position offset)))
point-position))
(defmethod move-point-right ((object point-tracker) max &key (offset 1))
(with-accessors ((point-position point-position)
(prompt prompt)) object
(let ((prompt-length (length prompt)))
(setf point-position
(min (+ max prompt-length)
(+ offset point-position))))
point-position))
(defmethod move-point ((object point-tracker) to max)
(with-accessors ((point-position point-position)
(prompt prompt)) object
(let ((prompt-length (length prompt)))
(setf point-position
(clamp (+ to prompt-length)
prompt-length
(+ max prompt-length)))
point-position)))
(defmethod move-point-to-end ((object point-tracker) text)
(let ((length (length text)))
(move-point object length length)))
(defmethod move-point-to-start ((object point-tracker))
(move-point object 0 1))
(defmethod insert-at-point ((object point-tracker) thing text)
(with-accessors ((point-position point-position)) object
(let* ((actual-point-pos (no-prompt-point-pos object))
(res (strcat (subseq text 0 actual-point-pos)
(to-s thing)
(subseq text actual-point-pos))))
(move-point-right object (length res))
res)))
(defmethod insert-at-point ((object point-tracker) thing (text null))
(insert-at-point object nil (to-s thing)))
(defmethod insert-at-point ((object point-tracker) (thing null) text)
(prog1
(to-s text)
(move-point-right object (length text))))
(defmethod delete-at-point ((object point-tracker) text &key (direction :right))
(with-accessors ((point-position point-position)) object
(handler-bind ((conditions:out-of-bounds
(lambda (c)
(declare (ignore c))
(invoke-restart 'misc:return-whole))))
(if (eq direction
:left)
(if (> (no-prompt-point-pos object)
0)
(progn
(move-point-left object)
(to-s (safe-delete@ text (no-prompt-point-pos object))))
(to-s text))
(to-s (safe-delete@ text (no-prompt-point-pos object)))))))

182
src/priority-queue.lisp Normal file
View File

@ -0,0 +1,182 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :priority-queue)
(defclass priority-queue ()
((heap
:initform (misc:make-array-frame 1 nil)
:initarg :heap
:accessor heap)
(key-function
:initform #'identity
:initarg :key-function
:accessor key-function)
(compare-function
:initform #'<
:initarg :compare-function
:accessor compare-function)
(equal-function
:initform (misc:make-array-frame 1 nil)
:initarg :equal-function
:accessor equal-function)))
(defmethod marshal:class-persistant-slots ((object priority-queue))
(append '(heap)
(call-next-method)))
(defgeneric get-children-pos (object parent-pos))
(defgeneric rearrange-bottom-up (object &optional pos))
(defgeneric rearrange-top-bottom (object &optional root-pos))
(defgeneric push-element (object val))
(defgeneric pop-element (object))
(defgeneric emptyp (object))
(defgeneric find-element (object element &key key-fn test-fn))
(defgeneric remove-element (object element))
(defgeneric count-elements-if (object predicate &key key-fn))
(defun get-parent-pos (pos)
(floor (/ pos 2)))
(defmethod get-children-pos ((object priority-queue) parent-pos)
(declare (integer parent-pos))
(with-accessors ((heap heap)) object
(list (and (< (* 2 parent-pos) (fill-pointer heap))
(* 2 parent-pos))
(and (< (1+ (* 2 parent-pos)) (fill-pointer heap))
(1+ (* 2 parent-pos))))))
(defmethod rearrange-bottom-up ((object priority-queue)
&optional (pos (1- (length (heap object)))))
(with-accessors ((heap heap)
(key-function key-function)
(compare-function compare-function)) object
(let ((parent-pos (get-parent-pos pos)))
(when (and (> parent-pos 0)
(funcall compare-function
(funcall key-function (elt heap pos))
(funcall key-function (elt heap parent-pos))))
(let ((swp (elt heap parent-pos)))
(setf (elt heap parent-pos) (elt heap pos))
(setf (elt heap pos) swp))
(rearrange-bottom-up object parent-pos)))))
(defmethod rearrange-top-bottom ((object priority-queue) &optional (root-pos 1))
(with-accessors ((heap heap)
(key-function key-function)
(compare-function compare-function)
(equal-function equal-function)) object
(let* ((children (remove-if #'null (get-children-pos object root-pos)))
(maximum-child (cond
((null children)
root-pos)
((= (length children) 1)
(first children))
(t
(if (funcall compare-function
(funcall key-function (elt heap (first children)))
(funcall key-function (elt heap (second children))))
(first children)
(second children))))))
(when (not (funcall equal-function
(funcall key-function (elt heap maximum-child))
(funcall key-function (elt heap root-pos))))
(let ((swp (elt heap root-pos)))
(when (funcall compare-function
(funcall key-function (elt heap maximum-child))
(funcall key-function swp))
(setf (elt heap root-pos) (elt heap maximum-child))
(setf (elt heap maximum-child) swp)))
(rearrange-top-bottom object maximum-child)))))
(defmethod push-element ((object priority-queue) val)
(with-accessors ((heap heap)) object
(vector-push-extend val heap)
(rearrange-bottom-up object)))
(defmethod emptyp ((object priority-queue))
(with-accessors ((heap heap)) object
(<= (length heap) 1)))
(defmethod pop-element ((object priority-queue))
(with-accessors ((heap heap)) object
(if (emptyp object)
nil
(prog1
(elt heap 1)
(if (= (length heap) 2)
(setf (fill-pointer heap) (1- (fill-pointer heap)))
(progn
(setf (elt heap 1) (alexandria:last-elt heap))
(setf (fill-pointer heap) (1- (fill-pointer heap)))
(rearrange-top-bottom object)))))))
(defmacro with-min-queue ((queue compare sort key) &body body)
`(let ((,queue (make-instance 'priority-queue
:equal-function ,compare
:compare-function ,sort
:key-function ,key)))
,@body))
(defmethod find-element ((object priority-queue) element
&key
(key-fn (key-function object))
(test-fn (equal-function object)))
(find element
(heap object)
:key key-fn
:test test-fn
:start 1))
(defmethod count-elements-if (object predicate
&key
(key-fn (key-function object)))
(count-if predicate
(heap object)
:key key-fn
:start 1))
(defmethod remove-element ((object priority-queue) element)
(with-accessors ((heap heap)
(key-function key-function)
(equal-function equal-function)
(compare-function compare-function)) object
(let ((pos (position element
heap
:start 1
:key (key-function object)
:test (equal-function object)))
(old-length (length heap)))
(if (and pos
(= pos 1))
(pop-element object)
(when pos
(misc:swap (elt heap pos)
(elt heap (1- (length heap))))
(setf (fill-pointer heap) (1- (fill-pointer heap)))
(when (not (= pos (1- old-length)))
(let ((parent-pos (get-parent-pos pos)))
(if (funcall compare-function (elt heap pos) (elt heap parent-pos))
(rearrange-bottom-up object pos)
(rearrange-top-bottom object pos)))))))))

769
src/program-events.lisp Normal file
View File

@ -0,0 +1,769 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/][http://www.gnu.org/licenses/]].
(in-package :program-events)
(defparameter *id-lock* (bt:make-recursive-lock))
(defparameter *event-id* 0)
;; used only in batch mode from the command line
(defparameter *process-events-immediately* nil
"Used only in batch mode from the command line. Instead of pushing the event on a priority queue that will be picked by a thread process the event immediately")
(define-constant +standard-event-priority+ 10 :test #'=)
;; keep this function stricly monotonic otherwise the order of
;; elements in priority queue is going to be messed up
(defun-w-lock next-id () *id-lock*
(incf *event-id*)
*event-id*)
(defmacro with-notify-errors (&body body)
`(handler-case
(progn
,@body)
(error (e)
(ui:notify (format nil (_ "Error: ~a") e)
:life (* (swconf:config-notification-life) 5)
:as-error t))))
(defclass program-event ()
((event-id
:initform (next-id)
:initarg :event-id
:accessor event-id)
(payload
:initform nil
:initarg :payload
:accessor payload)
(priority
:initform +standard-event-priority+
:initarg :priority
:accessor priority)))
(defmethod print-object ((object program-event) stream)
(print-unreadable-object (object stream :type t :identity nil)
(format stream "id ~a priority ~a" (event-id object) (priority object))))
(defgeneric process-event (object))
(defgeneric reinitialize-id (object))
(defmethod reinitialize-id ((object program-event))
(setf (event-id object)
(next-id))
object)
(defclass events-queue (priority-queue)
((lock
:initform (bt:make-recursive-lock)
:initarg :lock
:accessor lock)))
(defun queue-compare-predicate (a b)
(let ((same-priority-p (= (priority a)
(priority b))))
(if same-priority-p
(< (event-id a)
(event-id b))
(< (priority a)
(priority b)))))
(defun queue-equals-predicate (a b)
(= (event-id a)
(event-id b)))
(defmethod initialize-instance :after ((object events-queue) &key &allow-other-keys)
(with-accessors ((key-function key-function)
(compare-function compare-function)
(equal-function equal-function)) object
(setf key-function #'identity)
(setf equal-function #'queue-equals-predicate)
(setf compare-function #'queue-compare-predicate)))
(defmacro wrapped-in-lock ((queue) &body body)
(with-gensyms (lock)
`(with-accessors ((,lock lock)) ,queue
(with-lock (,lock)
,@body))))
(defparameter *events-queue* (make-instance 'events-queue))
(defun push-event (event)
(wrapped-in-lock (*events-queue*)
(if *process-events-immediately*
(process-event event)
(push-element *events-queue* event))))
(defun pop-event ()
(wrapped-in-lock (*events-queue*)
(pop-element *events-queue*)))
(defun remove-event (event)
(wrapped-in-lock (*events-queue*)
(remove-element *events-queue* event)))
(defun find-event (event &key (key-fn #'identity) (test-fn #'eq))
(wrapped-in-lock (*events-queue*)
(find-element *events-queue* event :test-fn test-fn :key-fn key-fn)))
(defun no-events-p ()
(wrapped-in-lock (*events-queue*)
(emptyp *events-queue*)))
(defun event-available-p ()
(not (no-events-p)))
(defun count-events (predicate)
(wrapped-in-lock (*events-queue*)
(count-elements-if *events-queue* predicate :key-fn #'identity)))
(defclass event-on-own-thread (program-event)
((lock
:initform (bt:make-recursive-lock)
:initarg :lock
:accessor lock)
(condition-variable
:initform (bt:make-condition-variable)
:initarg :condition-variable
:accessor condition-variable))
(:documentation "This is the parent of all events that are
generated in athread that is not the main thread, contains a
condition variable and associated lock"))
(defclass ask-user-input-string-event (event-on-own-thread)
((prompt
:initform +default-command-prompt+
:initarg :prompt
:accessor prompt)
(initial-value
:initform nil
:initarg :initial-value
:accessor initial-value)
(complete-fn
:initform nil
:initarg :complete-fn
:accessor complete-fn))
(:documentation "This events, when processed, will prepare the
command-window `specials:*command-window*' to ask for user
input. The most importatn thing is that the process-event will set
the slot `command-window:event-to-answer' with this events and will
set the payload of this events with the user provided string."))
(defmethod initialize-instance :after ((object ask-user-input-string-event)
&key &allow-other-keys)
(setf (priority object) (truncate (/ +standard-event-priority+ 2))))
(defmethod process-event ((object ask-user-input-string-event))
(with-accessors ((prompt prompt)
(initial-value initial-value)
(complete-fn complete-fn)) object
(setf (command-window:event-to-answer specials:*command-window*)
object)
(setf (point-tracker:prompt specials:*command-window*)
prompt)
(setf complete:*complete-function* complete-fn)
(command-window:set-string-mode specials:*command-window*)
(command-window:set-history-most-recent specials:*command-window* prompt)
(setf (command-window:command-line specials:*command-window*)
initial-value)
(point-tracker:move-point-to-end specials:*command-window* initial-value)
(windows:draw specials:*command-window*)))
(defclass user-input-string-event (ask-user-input-string-event)
()
(:documentation "When user provided a string as this event is
generated. When processed it just wlii notify the condition variable
of the slots `command-window:event-to-answer' in the object
`specials:*command-window*' so that the callee thread can restart
the computation with the input."))
(defmethod initialize-instance :after ((object user-input-string-event)
&key &allow-other-keys)
(setf (priority object) (truncate (/ +standard-event-priority+ 2))))
(defmethod process-event ((object user-input-string-event))
(with-accessors ((lock lock)
(condition-variable condition-variable)) object
(with-lock (lock)
(bt:condition-notify condition-variable))))
(defclass notify-user-event (program-event)
((added-to-pending-p
:initform nil
:initarg :added-to-pending
:reader added-to-pending-p
:writer (setf added-to-pending))
(life
:initform nil
:initarg :life
:accessor life)
(notify-error
:initform nil
:initarg :notify-error
:accessor notify-error)))
(defun notify-user-event-p (a)
(typep a 'notify-user-event))
(defmethod process-event ((object notify-user-event))
(with-accessors ((added-to-pending-p added-to-pending-p)
(notify-error notify-error)) object
(let ((other-notification-win (first (mtree:find-child-if specials:*main-window*
#'notify-window:notify-window-p)))
(pending-before (count-events #'notify-user-event-p)))
(if (null other-notification-win)
(let* ((life (or (life object)
(swconf:config-notification-life)))
(notify-win (notify-window:make-notification-window (payload object)
life
:pending
pending-before
:notify-error
notify-error)))
(notify-window:draw-pending notify-win))
(progn
(when (not added-to-pending-p)
(setf (notify-window:pending other-notification-win)
(1+ pending-before))
(notify-window:draw-pending other-notification-win)
(setf (added-to-pending object) t))
(progn
(setf (event-id object) ; id must be monotonic, so we need to give the event a new one
(next-id))
(push-event object)))))))
(defclass remove-notify-user-event (program-event) ())
(defmethod process-event ((object remove-notify-user-event))
(let ((win (payload object)))
(mtree:remove-child specials:*main-window* win)))
(defclass update-timeline-event (program-event)
((timeline-type
:initform nil
:initarg :timeline-type
:accessor timeline-type)
(folder
:initform nil
:initarg :folder
:accessor folder)
(local
:initform nil
:initarg :localp
:reader localp
:writer (setf local))
(min-id
:initform nil
:initarg :min-id
:accessor min-id)))
(defmethod process-event ((object update-timeline-event))
"Update a timeline, save messages, performs topological sorts"
(let ((statuses (payload object))
(timeline-type (timeline-type object))
(folder (folder object)))
#+debug-mode
(let ((dump (with-output-to-string (stream)
(mapcar (lambda (toot) (tooter::present toot stream))
statuses))))
(dbg "statuses ~a" dump))
(loop for status in statuses do
(db:update-db status
:timeline timeline-type
:folder folder
:skip-ignored-p t))
(db:renumber-timeline-message-index timeline-type
folder
:account-id nil)))
(defclass fetch-remote-status-event (program-event) ())
(defmethod process-event ((object fetch-remote-status-event))
(let ((status (payload object)))
#+debug-mode
(let ((dump (with-output-to-string (stream)
(tooter::present status stream))))
(dbg "fetch single status ~a" dump))
(db:update-db status)))
(defclass search-regex-message-content-event (program-event) ())
(defmethod process-event ((object search-regex-message-content-event))
(let ((regexp (payload object)))
(message-window:search-regex specials:*message-window* regexp)))
(defclass thread-goto-message (program-event) ())
(defmethod process-event ((object thread-goto-message))
(let ((message-index (payload object)))
(thread-window:goto-message specials:*thread-window* message-index)))
(defclass thread-search-event (program-event)
((search-direction
:initform nil
:initarg :search-direction
:accessor search-direction)))
(defclass thread-search-message-body-event (thread-search-event) ())
(defmethod process-event ((object thread-search-message-body-event))
(let ((text-looking-for (payload object))
(search-direction (search-direction object)))
(if (eq :next search-direction)
(thread-window:search-next-message-body specials:*thread-window* text-looking-for)
(thread-window:search-previous-message-body specials:*thread-window* text-looking-for))))
(defclass thread-search-message-meta-event (thread-search-event) ())
(defmethod process-event ((object thread-search-message-meta-event))
(let ((text-looking-for (payload object))
(search-direction (search-direction object)))
(if (eq :next search-direction)
(thread-window:search-next-message-meta specials:*thread-window* text-looking-for)
(thread-window:search-previous-message-meta specials:*thread-window* text-looking-for))))
(defclass delete-all-status-event (program-event) ())
(defmethod process-event ((object delete-all-status-event))
(db:forget-all-statuses-marked-deleted) ; do not change the order. Forget, then delete.
(db:delete-all-statuses-marked-deleted)
(db:renumber-all-timelines))
(defclass quit-program-event (program-event) ())
(defmethod process-event ((object quit-program-event))
(ui:quit-program))
(defclass error-message-event (program-event) ())
(defmethod process-event ((object error-message-event))
(command-window:add-error-message specials:*command-window* (payload object)))
(defclass info-message-event (program-event) ())
(defmethod process-event ((object info-message-event))
(command-window:add-info-message specials:*command-window* (payload object)))
(defclass dialog-event (program-event)
((buttons
:initform nil
:initarg :buttons
:accessor buttons)
(title
:initform nil
:initarg :title
:accessor title)))
(defclass error-dialog-event (dialog-event)
((buttons
:initform nil
:initarg :buttons
:accessor buttons)
(title
:initform nil
:initarg :title
:accessor title)))
(defmethod process-event ((object error-dialog-event))
(let ((dialog-window (windows:make-error-message-dialog specials:*main-window*
(title object)
(payload object)
(buttons object))))
(windows:menu-select dialog-window)))
(defclass info-dialog-event (dialog-event) ())
(defmethod process-event ((object info-dialog-event))
(let ((dialog-window (windows:make-info-message-dialog specials:*main-window*
(title object)
(payload object)
(buttons object))))
(windows:menu-select dialog-window)))
(defclass move-selected-tree-event (program-event)
((new-folder
:initform nil
:initarg :new-folder
:accessor new-folder)))
(defmethod process-event ((object move-selected-tree-event))
(let ((selected-fields (line-oriented-window:selected-row-fields
specials:*thread-window*)))
(if selected-fields
(db:move-tree-to-folder (db:row-message-timeline selected-fields)
(db:row-message-folder selected-fields)
(db:row-message-index selected-fields)
(new-folder object))
(ui:error-message (_ "No message selected!")))))
(defclass event-with-message-index ()
((message-index
:initform db:+message-index-start+
:initarg :message-index
:accessor message-index)))
(defclass event-with-timeline-and-folder ()
((new-folder
:initform nil
:initarg :new-folder
:accessor new-folder)
(new-timeline
:initform nil
:initarg :new-timeline
:accessor new-timeline)))
(defclass refresh-thread-windows-event (program-event
event-with-message-index
event-with-timeline-and-folder)
())
(defmethod process-event ((object refresh-thread-windows-event))
(with-accessors ((new-folder new-folder)
(new-timeline new-timeline)
(message-index message-index)) object
(assert message-index)
(when new-timeline
(setf (thread-window:timeline-type specials:*thread-window*)
new-timeline))
(when new-folder
(setf (thread-window:timeline-folder specials:*thread-window*)
new-folder))
(line-oriented-window:resync-rows-db specials:*thread-window*
:suggested-message-index message-index
:redraw t)))
(defun change-status-values (event function-change)
(with-accessors ((payload payload)
(message-index message-index)) event
(when-let ((status-to-change payload))
(funcall function-change status-to-change)
(client:fetch-remote-status status-to-change)
(let* ((refresh-event (make-instance 'refresh-thread-windows-event
:message-index message-index)))
(push-event refresh-event)))))
(defclass favourite-status-event (program-event event-with-message-index) ())
(defmethod process-event ((object favourite-status-event))
(with-notify-errors
(change-status-values object #'api-client:favourite-status)))
(defclass unfavourite-status-event (program-event event-with-message-index) ())
(defmethod process-event ((object unfavourite-status-event))
(with-notify-errors
(change-status-values object #'api-client:unfavourite-status)))
(defclass reblog-status-event (program-event event-with-message-index) ())
(defmethod process-event ((object reblog-status-event))
(with-notify-errors
(change-status-values object #'api-client:reblog-status)))
(defclass unreblog-status-event (program-event event-with-message-index) ())
(defmethod process-event ((object unreblog-status-event))
(with-notify-errors
(change-status-values object #'api-client:unreblog-status)))
(defclass unignore-user-event (program-event) ())
(defmethod process-event ((object unignore-user-event))
(let ((username (payload object)))
(db:unignore-author username)))
(defclass send-message-change-subject-event (program-event) ())
(defmethod process-event ((object send-message-change-subject-event))
(let ((new-subject (payload object)))
(setf (sending-message:subject (sending-message:message-data specials:*send-message-window*))
new-subject)
(windows:draw specials:*send-message-window*)))
(defclass send-message-change-visibility-event (program-event) ())
(defmethod process-event ((object send-message-change-visibility-event))
(let ((new-visibility (payload object))
(message-data (sending-message:message-data specials:*send-message-window*)))
(setf (sending-message:visibility message-data) new-visibility)
(windows:draw specials:*send-message-window*)))
(defclass open-send-message-window-event (program-event) ())
(defmethod process-event ((object open-send-message-window-event))
(let ((message-data (payload object)))
(sending-message:init message-data specials:*main-window*)
(ui:focus-to-send-message-window)
(windows:draw specials:*send-message-window*)))
(defclass send-message-add-attachment-event (program-event) ())
(defmethod process-event ((object send-message-add-attachment-event))
(with-accessors ((croatoan-window windows:croatoan-window)) specials:*send-message-window*
(let* ((new-attachment (payload object))
(fg (croatoan:fgcolor croatoan-window))
(bg (croatoan:bgcolor croatoan-window))
(line (make-instance 'line-oriented-window:line
:normal-text new-attachment
:selected-text new-attachment
:normal-bg bg
:normal-fg fg
:selected-bg fg
:selected-fg bg)))
(setf (line-oriented-window:rows specials:*send-message-window*)
(append (line-oriented-window:rows specials:*send-message-window*)
(list line)))
(line-oriented-window:unselect-all specials:*send-message-window*)
(line-oriented-window:select-row specials:*send-message-window* 0)
(windows:draw specials:*send-message-window*))))
(defclass send-message-event (program-event)
((use-ui-notification
:initform nil
:initarg :use-ui-notification
:reader use-ui-notification-p
:writer use-ui-notification)))
(defmethod process-event ((object send-message-event))
(with-accessors ((message-data sending-message:message-data)
(rows line-oriented-window:rows)) specials:*send-message-window*
(with-accessors ((body sending-message:body)
(subject sending-message:subject)
(reply-to sending-message:reply-to)
(visibility sending-message:visibility)) message-data
(let* ((attachments (mapcar #'line-oriented-window:normal-text rows)))
(hooks:run-hook 'hooks:*before-sending-message* object)
(msg-utils:maybe-crypt-message specials:*send-message-window*
:notify-cant-crypt (use-ui-notification-p object))
(let ((exceeding-characters (ui:message-exceeds-server-limit-p body)))
(if exceeding-characters
(ui:exceeding-characters-notify exceeding-characters)
(progn
(client:send-status body
reply-to
attachments
subject
(make-keyword (string-upcase visibility)))
(ui:notify (_ "Message sent."))
(ui:close-send-message-window))))))))
(defclass follow-user-event (program-event) ())
(defmethod process-event ((object follow-user-event))
(when-let ((username (payload object)))
(when (find username (db:all-unfollowed-usernames) :test #'string=)
(let ((user-id (db:acct->id username)))
(client:follow-user user-id)
(db:add-to-followers user-id)))))
(defclass unfollow-user-event (program-event) ())
(defmethod process-event ((object unfollow-user-event))
(when-let ((username (payload object)))
(when (find username (db:all-followed-usernames) :test #'string=)
(let ((user-id (db:acct->id username)))
(client:unfollow-user user-id)
(db:remove-from-followers user-id)))))
(defclass open-follow-requests-window-event (program-event) ())
(defmethod process-event ((object open-follow-requests-window-event))
(with-notify-errors
(multiple-value-bind (accounts usernames)
(api-client:follow-requests)
(when accounts
(follow-requests:init accounts usernames specials:*main-window*)
(ui:focus-to-follow-requests-window)
(windows:draw specials:*follow-requests-window*)))))
(defclass subscribe-tags-event (program-event) ())
(defmethod process-event ((object subscribe-tags-event))
(when-let* ((tags (payload object)))
(loop for tag in (cl-ppcre:split db:+tag-separator+ tags) do
(db:subscribe-to-tag tag))))
(defclass unsubscribe-tags-event (program-event) ())
(defmethod process-event ((object unsubscribe-tags-event))
(when-let* ((tag (payload object)))
(db:unsubscribe-to-tag tag)))
(defclass update-last-refresh-subscribe-tags-event (program-event) ())
(defmethod process-event ((object update-last-refresh-subscribe-tags-event))
(db:update-last-seen-status-subscribed-tag))
(defclass notify-fetched-new-tag-messages-event (program-event) ())
(defmethod process-event ((object notify-fetched-new-tag-messages-event))
(loop for tag in (db:all-tags-with-new-message-fetched) do
(let ((message (format nil
(_ "Downloaded new messages for tag ~a")
(db:tag->folder-name tag))))
(ui:notify message))))
(defclass tag-mark-got-messages-event (program-event) ())
(defmethod process-event ((object tag-mark-got-messages-event))
(loop for tag in (db:all-tags-with-new-message-fetched) do
(db:mark-tag-got-new-messages tag)))
(defclass refresh-tag-window-event (program-event) ())
(defmethod process-event ((object refresh-tag-window-event))
(tags-window:resync-rows-db specials:*tags-window*))
(defclass update-conversations-event (program-event
event-with-timeline-and-folder)
())
(defun add-new-conversations ()
(let* ((new-conversations (api-client:conversations :root-only t))
(all-conversations-id (db:all-conversations-id :remove-ignored nil))
(new-conversations (remove-if (lambda (conversation)
(find-if (lambda (a)
(string= (api-client:id conversation)
a))
all-conversations-id))
new-conversations)))
(loop for new-conversation in new-conversations do
(let ((root-id (client:conversation-root-id new-conversation)))
(when (not (db:conversation-root-captured-p root-id))
(db:add-conversation (api-client:id new-conversation)
root-id))))))
(defun fetch-conversations (message-root-id conversation-folder)
(let* ((conversation-tree (api-client:expand-conversations-tree message-root-id))
(event (make-instance 'update-timeline-event
:payload conversation-tree
:timeline-type db:+default-converation-timeline+
:folder conversation-folder
:localp nil)))
(push-event event)
conversation-tree))
(defmethod process-event ((object update-conversations-event))
(with-accessors ((new-timeline new-timeline)
(new-folder new-folder)) object
(with-notify-errors
(add-new-conversations)
(let* ((all-conversations (db:all-conversations)))
(loop for conversation in all-conversations do
(let* ((conversation-root (db:row-conversation-root-status-id conversation))
(conversation-folder (db:row-conversation-folder conversation)))
(fetch-conversations conversation-root conversation-folder)))
;; refresh-ui
(let ((refresh-thread (make-instance 'refresh-thread-windows-event
:new-timeline new-timeline
:new-folder new-folder))
(refresh-conversation
(make-instance 'refresh-conversations-window-event)))
(push-event refresh-thread)
(push-event refresh-conversation))))))
(defclass change-conversation-name-event (program-event)
((old-name
:initform nil
:initarg :old-name
:accessor old-name)
(new-name
:initform nil
:initarg :new-name
:accessor new-name)))
(defmethod process-event ((object change-conversation-name-event))
(db:change-conversation-name (old-name object)
(new-name object)))
(defclass refresh-conversations-window-event (program-event) ())
(defmethod process-event ((object refresh-conversations-window-event))
(conversations-window:resync-rows-db specials:*conversations-window*))
(defclass ignore-conversations-event (program-event) ())
(defmethod process-event ((object ignore-conversations-event))
(when-let* ((selected-row (line-oriented-window:selected-row
specials:*conversations-window*))
(folder (line-oriented-window:normal-text selected-row))
(refresh-event (make-instance 'refresh-conversations-window-event)))
(db:ignore-conversation folder)))
(defclass delete-conversations-event (program-event) ())
(defmethod process-event ((object delete-conversations-event))
(when-let* ((selected-row (line-oriented-window:selected-row
specials:*conversations-window*))
(fields (line-oriented-window:selected-row-fields
specials:*conversations-window*))
(folder (line-oriented-window:normal-text selected-row))
(id (db:conversation-id fields))
(refresh-event (make-instance 'refresh-conversations-window-event)))
(with-notify-errors
(api-client:delete-conversation id)
(db:delete-conversation folder))))
(defclass report-status-event (program-event)
((status-id
:initform nil
:initarg :status-id
:accessor status-id)
(account-id
:initform nil
:initarg :account-id
:accessor account-id)
(comment
:initform nil
:initarg :comment
:accessor comment)
(forwardp
:initform nil
:initarg :forwardp
:accessor forwardp)))
(defmethod process-event ((object report-status-event))
(with-accessors ((status-id status-id)
(account-id account-id)
(comment comment)
(forwardp forwardp)) object
(with-notify-errors
(api-client:make-report account-id status-id comment forwardp))))
(defclass add-crypto-data-event (program-event)
((username
:initform nil
:initarg :username
:accessor username)
(key
:initform nil
:initarg :key
:accessor key)))
(defmethod process-event ((object add-crypto-data-event))
(with-accessors ((username username)
(key key)) object
(db:import-crypto-data (db:acct->id username)
key)))
;;;; end events
(defun dispatch-program-events ()
(when (event-available-p)
(process-event (pop-event))))

102
src/queue.lisp Normal file
View File

@ -0,0 +1,102 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :queue)
(defparameter *queue* (misc:make-array-frame 0))
(defparameter *equal-function* #'equalp)
(defparameter *key-function* #'identity)
(defun push (val)
(vector-push-extend val *queue*))
(defun pop ()
(if (not (emptyp))
(prog1
(alexandria:first-elt *queue*)
(setf *queue* (misc:safe-delete@ *queue* 0)))
nil))
(defun find (element)
(cl:find element *queue* :key *key-function* :test *equal-function*))
(defun emptyp ()
(not (> (length *queue*) 0)))
(defmacro with-queue ((equal key) &body body)
`(let ((*queue* (misc:make-array-frame 0))
(*equal-function* ,equal)
(*key-function* ,key))
,@body))
(defclass simple-queue ()
((container
:initform (misc:make-array-frame 0)
:accessor container)))
(defgeneric q-pop (object))
(defgeneric q-peek (object))
(defgeneric q-push (object value))
(defgeneric q-empty-p (object))
(defgeneric q-size (object))
(defgeneric q-sort (object predicate))
(defgeneric q-dbg-print (object))
(defmethod q-pop ((object simple-queue))
(with-accessors ((container container)) object
(let ((peek (q-peek object)))
(if peek
(progn
(setf container (misc:safe-delete@ container 0))
peek)
nil))))
(defmethod q-push ((object simple-queue) value)
(with-accessors ((container container)) object
(vector-push-extend value container)))
(defmethod q-empty-p ((object simple-queue))
(with-accessors ((container container)) object
(misc:vector-empty-p container)))
(defmethod q-peek ((object simple-queue))
(with-accessors ((container container)) object
(if (not (q-empty-p object))
(elt container 0)
nil)))
(defmethod q-size ((object simple-queue))
(length (container object)))
(defmethod q-sort ((object simple-queue) predicate)
(with-accessors ((container container)) object
(setf container (stable-sort container predicate))))
(defmethod q-dbg-print ((object simple-queue))
(misc:dbg "--queue--")
(loop
for i from 0
for a across (container object) do
(misc:dbg "~a ~a" i a))
(misc:dbg "----"))

518
src/rb-tree.lisp Normal file
View File

@ -0,0 +1,518 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :rb-tree)
(alexandria:define-constant +rb-red+ :red :test #'eq)
(alexandria:define-constant +rb-black+ :black :test #'eq)
(alexandria:define-constant +rb-neg-black+ :neg-black :test #'eq)
(alexandria:define-constant +rb-black-black+ :black-black :test #'eq)
(alexandria:define-constant +rb-color+ :color :test #'eq)
(defun incf-black (color)
(cond
((eq color +rb-black+)
+rb-black-black+)
((eq color +rb-red+)
+rb-black+)
((eq color +rb-neg-black+)
+rb-red+)))
(defun decf-black (color)
(cond
((eq color +rb-black-black+)
+rb-black+)
((eq color +rb-black+)
+rb-red+)
((eq color +rb-red+)
+rb-neg-black+)))
(defclass rb-node (node)
((color
:initarg :color
:initform +rb-black+
:accessor color)))
(defgeneric balance (object))
(defgeneric bubble (object))
(defgeneric balancedp (object))
(defgeneric left-balance (object))
(defgeneric right-balance (object))
(defgeneric remove-max-node (object key key-datum compare equal))
(defgeneric %remove-node (object needle key key-datum compare equal))
(defgeneric remove-node (object needle &key key key-datum compare equal))
(defmethod node->string ((object rb-node))
(if (null (data object))
(format nil "leaf color ~a" (color object))
(format nil "~a (~a)~% [~a] [~a]"
(data object)
(color object)
(node->string (left object))
(node->string (right object)))))
(defun make-rb-node (color data left right parent)
(make-instance 'rb-node :color color :left left :right right :data data :parent parent))
(defun make-rb-leaf (color parent)
(make-instance 'rb-node :color color :parent parent :left nil :right nil))
(defun make-root-rb-node (datum color)
(let* ((tree (make-rb-node color datum nil nil nil))
(l-leaf (make-rb-leaf +rb-black+ tree))
(r-leaf (make-rb-leaf +rb-black+ tree)))
(setf (left tree) l-leaf
(right tree) r-leaf)
tree))
(defmethod insert ((object rb-node) datum &key
(key #'identity) (key-datum #'identity)
(compare #'<) (equal #'=))
(macrolet ((make-leaf-node (datum left right parent)
`(make-rb-node +rb-red+ ,datum ,left ,right ,parent))
(make-leaf (new-node)
`(make-rb-leaf +rb-black+ ,new-node))
(make-node (data left right parent)
`(make-rb-node (color node) ,data ,left ,right ,parent)))
(with-insert-local-function (make-node make-node make-leaf-node make-leaf
left-balance right-balance)
(let ((balanced (%insert object datum key key-datum compare equal)))
(setf (color balanced) +rb-black+)
balanced))))
(defmacro with-match-tree ((color left data right) tree &body body)
`(and (or (not ,color)
(eq ,color (color ,tree)))
(let ((,data (data ,tree)))
(declare (ignorable ,data))
,(if (consp left)
`(with-match-tree ,left (left ,tree)
,(if (consp right)
`(with-match-tree ,right (right ,tree)
,@body)
`(let ((,right (right ,tree)))
(declare (ignorable ,right))
,@body)))
`(let ((,left (left ,tree)))
(declare (ignorable ,left))
,(if (consp right)
`(with-match-tree ,right (right ,tree)
,@body)
`(let ((,right (right ,tree)))
(declare (ignorable ,right))
,@body)))))))
(defmethod balance ((object rb-node))
(macrolet ((setf-parent (new-node)
`(setf (parent (left ,new-node)) ,new-node
(parent (right ,new-node)) ,new-node
(parent (left (left ,new-node))) (left ,new-node)
(parent (right (left ,new-node))) (left ,new-node)
(parent (right (right ,new-node))) (right ,new-node)
(parent (left (right ,new-node))) (right ,new-node))))
(with-match-tree (+rb-black+ (+rb-red+ (+rb-red+ a x b) y c) z d) object
(return-from balance
(let ((new-node (make-rb-node +rb-red+ y
(make-rb-node +rb-black+ x a b nil)
(make-rb-node +rb-black+ z c d nil)
(parent object))))
(setf-parent new-node)
new-node)))
(with-match-tree (+rb-black+ (+rb-red+ a x (+rb-red+ b y c)) z d) object
(return-from balance
(let ((new-node (make-rb-node +rb-red+ y
(make-rb-node +rb-black+ x a b nil)
(make-rb-node +rb-black+ z c d nil)
(parent object))))
(setf-parent new-node)
new-node)))
(with-match-tree (+rb-black+ a x (+rb-red+ (+rb-red+ b y c) z d)) object
(return-from balance
(let ((new-node (make-rb-node +rb-red+ y
(make-rb-node +rb-black+ x a b nil)
(make-rb-node +rb-black+ z c d nil)
(parent object))))
(setf-parent new-node)
new-node)))
(with-match-tree (+rb-black+ a x (+rb-red+ b y (+rb-red+ c z d))) object
(return-from balance
(let ((new-node (make-rb-node +rb-red+ y
(make-rb-node +rb-black+ x a b nil)
(make-rb-node +rb-black+ z c d nil)
(parent object))))
(setf-parent new-node)
new-node)))
;; for deletion
(with-match-tree (+rb-black-black+ (+rb-red+ a x (+rb-red+ b y c)) z d) object
(return-from balance
(let ((new-node (make-rb-node +rb-black+
y
(make-rb-node +rb-black+ x a b nil)
(make-rb-node +rb-black+ z c d nil)
(parent object))))
(setf-parent new-node)
new-node)))
(with-match-tree (+rb-black-black+ (+rb-red+ (+rb-red+ a x b) y c) z d) object
(return-from balance
(let ((new-node (make-rb-node +rb-black+
y
(make-rb-node +rb-black+ x a b nil)
(make-rb-node +rb-black+ z c d nil)
(parent object))))
(setf-parent new-node)
new-node)))
(with-match-tree (+rb-black-black+ a x (+rb-red+ (+rb-red+ b y c) z d)) object
(return-from balance
(let ((new-node (make-rb-node +rb-black+
y
(make-rb-node +rb-black+ x a b nil)
(make-rb-node +rb-black+ z c d nil)
(parent object))))
(setf-parent new-node)
new-node)))
(with-match-tree (+rb-black-black+ a x (+rb-red+ b y (+rb-red+ c z d))) object
(return-from balance
(let ((new-node (make-rb-node +rb-black+
y
(make-rb-node +rb-black+ x a b nil)
(make-rb-node +rb-black+ z c d nil)
(parent object))))
(setf-parent new-node)
new-node)))
(with-match-tree (+rb-black-black+ (+rb-neg-black+ (+rb-black+ a w b)
x
(+rb-black+ c y d))
z
e) object
(return-from balance
(let ((new-node (make-rb-node +rb-black+
y
(balance (make-rb-node +rb-black+
x
(make-rb-node +rb-red+ w a b nil)
c
nil))
(make-rb-node +rb-black+ z d e nil)
(parent object))))
(setf-parent new-node)
(balance new-node))))
(with-match-tree (+rb-black-black+ a
x
(+rb-neg-black+ (+rb-black+ b y c)
z
(+rb-black+ j n i))) object
(return-from balance
(let ((new-node (make-rb-node +rb-black+
y
(make-rb-node +rb-black+
x
a
b
nil)
(balance (make-rb-node +rb-black+
z
c
(make-rb-node +rb-red+ n j i nil)
nil))
(parent object))))
(setf-parent new-node)
(balance new-node))))
object))
(defmethod bubble ((object rb-node))
(if (or (eq (color (left object)) +rb-black-black+)
(eq (color (right object)) +rb-black-black+))
;; TODO reconstruct-parent!
(balance (make-rb-node (incf-black (color object))
(data object)
(make-rb-node (decf-black (color (left object)))
(data (left object))
(left (left object))
(right (left object))
nil)
(make-rb-node (decf-black (color (right object)))
(data (right object))
(left (right object))
(right (right object))
nil)
nil))
(balance object)))
(defmethod left-balance ((object rb-node))
(macrolet ((setf-parent (new-node)
`(setf (parent (left ,new-node)) ,new-node
(parent (right ,new-node)) ,new-node
(parent (left (left ,new-node))) (left ,new-node)
(parent (right (left ,new-node))) (left ,new-node)
(parent (right (right ,new-node))) (right ,new-node)
(parent (left (right ,new-node))) (right ,new-node))))
(with-match-tree (+rb-black+ (+rb-red+ (+rb-red+ a x b) y c) z d) object
(return-from left-balance
(let ((new-node (make-rb-node +rb-red+ y
(make-rb-node +rb-black+ x a b nil)
(make-rb-node +rb-black+ z c d nil)
(parent object))))
(setf-parent new-node)
new-node)))
(with-match-tree (+rb-black+ (+rb-red+ a x (+rb-red+ b y c)) z d) object
(return-from left-balance
(let ((new-node (make-rb-node +rb-red+ y
(make-rb-node +rb-black+ x a b nil)
(make-rb-node +rb-black+ z c d nil)
(parent object))))
(setf-parent new-node)
new-node)))
object))
(defmethod right-balance ((object rb-node))
(macrolet ((setf-parent (new-node)
`(setf (parent (left ,new-node)) ,new-node
(parent (right ,new-node)) ,new-node
(parent (left (left ,new-node))) (left ,new-node)
(parent (right (left ,new-node))) (left ,new-node)
(parent (right (right ,new-node))) (right ,new-node)
(parent (left (right ,new-node))) (right ,new-node))))
(with-match-tree (+rb-black+ a x (+rb-red+ (+rb-red+ b y c) z d)) object
(return-from right-balance
(let ((new-node (make-rb-node +rb-red+ y
(make-rb-node +rb-black+ x a b nil)
(make-rb-node +rb-black+ z c d nil)
(parent object))))
(setf-parent new-node)
new-node)))
(with-match-tree (+rb-black+ a x (+rb-red+ b y (+rb-red+ c z d))) object
(return-from right-balance
(let ((new-node (make-rb-node +rb-red+ y
(make-rb-node +rb-black+ x a b nil)
(make-rb-node +rb-black+ z c d nil)
(parent object))))
(setf-parent new-node)
new-node)))
object))
(defmethod map ((object rb-node) function)
(with-accessors ((color color) (data data) (left left) (right right)) object
(if (leafp object)
(make-rb-leaf color nil)
(make-rb-node color (funcall function data)
(map left function)
(map right function) nil))))
(defmethod map-node ((object rb-node) function)
(with-accessors ((color color) (data data) (left left) (right right)) object
(if (leafp object)
(funcall function object (make-rb-leaf color object))
(funcall function object (make-rb-node color data
(map-node left function)
(map-node right function) nil)))))
(defmethod reconstruct-parent ((object rb-node) &optional (parent (parent object)))
(with-accessors ((color color) (data data) (left left) (right right)) object
(if (leafp object)
(make-rb-leaf color parent)
(make-rb-node color data
(reconstruct-parent left object)
(reconstruct-parent right object) parent))))
(defmethod remove-max-node ((object node) key key-datum compare equal)
(if (leafp (right object))
(%remove-node object (data object) key key-datum compare equal)
(bubble (make-rb-node (color object)
(data object)
(left object)
(remove-max-node (right object)
key
key-datum
compare
equal)
nil))))
(defmethod %remove-node ((object node) needle key key-datum compare equal)
(cond
((leafp object)
object)
((funcall equal (%key key (data object)) (%key key-datum needle)) ;; equal, delete
(cond
((and (all-children-leaf-p object) ; no children, red color
(eq (color object) +rb-red+))
(make-rb-leaf +rb-black+ nil))
((and (all-children-leaf-p object) ; no children, black color
(eq (color object) +rb-black+))
(make-rb-leaf +rb-black-black+ nil))
((and (leafp (left object)) ;; one child on right
(not (leafp (right object))))
(make-rb-node +rb-black+
(data (right object))
(left (right object))
(right (right object))
nil))
((and (leafp (right object)) ; one child on left
(not (leafp (left object))))
(make-rb-node +rb-black+
(data (left object))
(left (left object))
(right (left object))
nil))
(t ; two children
(let* ((max-node (find-max-node (left object)))
(max-data (data max-node)))
(bubble (make-rb-node (color object)
max-data
(remove-max-node (left object)
key
key
compare
equal)
(right object)
nil)))))) ;; end removing block
((funcall compare (%key key-datum needle) (%key key (data object)))
(bubble (make-rb-node (color object)
(data object)
(%remove-node (left object) needle key key-datum compare equal)
(right object)
nil)))
(t ; go right, needle is greater then this node
(bubble (make-rb-node (color object)
(data object)
(left object)
(%remove-node (right object) needle key key-datum compare equal)
nil)))))
(defmethod remove-node ((object rb-node) needle &key
(key #'identity) (key-datum #'identity)
(compare #'<) (equal #'=))
(let ((new (%remove-node object needle key key-datum compare equal)))
(setf (color new) +rb-black+)
new))
(defmethod node->dot ((object rb-node))
(labels ((color->hex (node)
(cond
((eq (color node) +rb-red+)
"#ff0000")
((eq (color node) +rb-black-black+)
"#ff00ff")
((eq (color node) +rb-neg-black+)
"#a1a1a1")
(t
"#ffffff")))
(nodes ()
(append
(list
`(:node ((:id ,(format nil "~a" (data object)))
(:label ,(format nil "~ap~a" (data object)
(data (parent object))))
(:style "filled")
(:fillcolor ,(color->hex object)))))
(if (not (leafp (left object)))
(node->dot (left object))
(list
`(:node ((:id ,(format nil "nil-l~a" (data object)))
(:label "nil")
(:style "filled")
(:fillcolor ,(color->hex (left object)))))))
(if (not (leafp (right object)))
(node->dot (right object))
(list
`(:node ((:id ,(format nil "nil-r~a" (data object)))
(:label "nil")
(:style "filled")
(:fillcolor ,(color->hex (right object)))))))))
(edges ()
(append
(if (data (left object))
(list `(:edge
((:from ,(format nil "~a" (data object)))
(:to ,(format nil "~a" (data (left object)))))))
(list `(:edge
((:from ,(format nil "~a" (data object)))
(:to ,(format nil "nil-l~a" (data object)))))))
(if (data (right object))
(list `(:edge
((:from ,(format nil "~a" (data object)))
(:to ,(format nil "~a" (data (right object)))))))
(list `(:edge
((:from ,(format nil "~a" (data object)))
(:to ,(format nil "nil-r~a" (data object))))))))))
(append (nodes) (edges))))
(defmethod to-sexp ((object rb-node))
(let ((*print-circle* t))
(list +data+ (to-sexp (data object))
+rb-color+ (color object)
+left+ (to-sexp (left object))
+right+ (to-sexp (right object))
+parent+ (to-sexp (data (parent object))))))
(defmethod from-sexp ((object rb-node) sexp)
(declare (ignorable object))
(labels ((%from-sexp (sexp)
(if (null sexp)
(make-rb-leaf +rb-black+ nil)
(make-rb-node (getf sexp +rb-color+)
(getf sexp +data+)
(from-sexp object (getf sexp +left+))
(from-sexp object (getf sexp +right+)) nil))))
(let ((new-tree (%from-sexp sexp)))
(reconstruct-parent new-tree))))
(defmethod balancedp ((object rb-node))
(let ((black-paths-count '()))
(labels ((all-red-child-black-p (node)
(map-node node #'(lambda (n b)
(declare (ignore b))
(if (or (eq (color n) +rb-black+)
(and (eq (color n) +rb-red+)
(eq (color (left n)) +rb-black+)
(eq (color (right n)) +rb-black+)))
t
(return-from all-red-child-black-p nil)))))
(all-path-black-same-length (node &optional (ct 0))
(when (eq (color node) +rb-black+)
(incf ct))
(if (leafp node)
(progn
(push ct black-paths-count)
(decf ct))
(progn
(all-path-black-same-length (left node) ct)
(all-path-black-same-length (right node) ct)))))
(all-path-black-same-length object)
(and (every #'(lambda (a) (= a (elt black-paths-count 0))) black-paths-count)
(all-red-child-black-p object)))))

69
src/resources-utils.lisp Normal file
View File

@ -0,0 +1,69 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :resources-utils)
(alexandria:define-constant +virtual-fs-dir-separator+ "/" :test #'string=)
(alexandria:define-constant +virtual-fs-dir-separator-regexp+ "\\/" :test #'string=)
(defun construct-path (p)
(let ((splitted (split +virtual-fs-dir-separator-regexp+ p)))
(strcat *directory-sep* (join-with-strings splitted *directory-sep*)
(if (cl-ppcre:scan (strcat +virtual-fs-dir-separator-regexp+ "$") p)
*directory-sep*))))
(defun home-datadir ()
(concatenate 'string
(pathname->namestring (uiop:xdg-data-home +program-name+))
"/"))
(defun home-confdir ()
(pathname->namestring (uiop:xdg-config-home +program-name+)))
(defun init ()
#+debug-mode
(progn
(when (not (directory-exists-p (home-datadir)))
(misc:dbg "creating ~a" (home-datadir)))
(when (not (directory-exists-p (home-confdir)))
(misc:dbg "creating ~a" (home-confdir))))
(fs:make-directory (home-datadir))
(fs:make-directory (home-confdir)))
(defun get-resource-file (system-dir home-dir path)
(let ((system-file (fs:cat-parent-dir system-dir path))
(home-file (fs:cat-parent-dir home-dir path)))
(cond
((fs:file-exists-p home-file)
home-file)
((fs:file-exists-p system-file)
system-file)
(t
(let ((msg (_ "Unrecoverable error: cannot find ~s in either ~s or ~s.")))
(restart-case
(error (format nil msg path system-file home-file))
(return-home-filename (e)
(declare (ignore e))
home-file)
(return-system-filename (e)
(declare (ignore e))
system-file)))))))
(defun get-config-file (path)
(get-resource-file +sys-conf-dir+ (home-confdir) path))
(defun get-data-file (path)
(get-resource-file +sys-data-dir+ (home-datadir) path))

192
src/sending-message.lisp Normal file
View File

@ -0,0 +1,192 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :sending-message)
(define-constant +header-send-window-height+ 5 :test #'=)
(defclass message-ready-to-send ()
((subject
:initform nil
:initarg :subject
:accessor subject)
(attachments
:initform ()
:initarg :attachments
:accessor attachments)
(reply-to
:initform ()
:initarg :reply-to
:accessor reply-to
:documentation "The id of table 'status' you are replying to.")
(visibility
:initform +status-public-visibility+
:initarg :visibility
:accessor visibility
:documentation "One of swconf:*allowed-status-visibility*.")
(body
:initform nil
:initarg :body
:accessor body)))
(defmethod print-object ((object message-ready-to-send) stream)
(print-unreadable-object (object stream :type t)
(with-accessors ((subject subject)
(attachments attachments)
(reply-to reply-to)
(body body)) object
(format stream
"~@[subj: ~a ~] ~@[reply-to: ~a ~] ~@[attach: ~a ~] ~a"
subject reply-to attachments body))))
(defclass confirm-sending-window (focus-marked-window simple-line-navigation-window)
((screen
:initarg :screen
:initform nil
:accessor screen)
(message-data
:initarg :message-data
:initform (make-instance 'message-ready-to-send)
:accessor message-data
:type message-ready-to-send)
(style
:initarg :style
:initform nil
:accessor style)))
(defmethod refresh-config :after ((object confirm-sending-window))
(with-accessors ((screen screen)
(croatoan-window croatoan-window)
(bgcolor bgcolor)
(fgcolor fgcolor)
(top-row-padding top-row-padding)
(style style)) object
(let* ((theme-style (swconf:form-style swconf:+key-input-dialog+))
(fg (swconf:foreground theme-style))
(bg (swconf:background theme-style))
(width (truncate (/ (win-width screen)
2)))
(height (truncate (/ (win-height screen)
2)))
(y (truncate (- (/ (win-height screen) 2)
(/ height 2))))
(x (truncate (- (/ (win-width screen) 2)
(/ width 2))))
(attach-y-start +header-send-window-height+))
(setf (background croatoan-window)
(tui:make-background bg))
(setf (bgcolor croatoan-window) bg)
(setf (fgcolor croatoan-window) fg)
(setf style theme-style)
(win-resize object width height)
(win-move object x y)
(setf (top-row-padding object) attach-y-start)
object)))
(defmethod draw :after ((object confirm-sending-window))
(with-accessors ((message-data message-data)
(style style)) object
(with-accessors ((reply-to reply-to)
(attachments attachments)
(body body)
(subject subject)
(visibility visibility)) message-data
(with-croatoan-window (croatoan-window object)
(let* ((bgcolor (bgcolor croatoan-window))
(fgcolor (fgcolor croatoan-window))
(input-bg (swconf:input-background style))
(input-fg (swconf:input-foreground style))
(user (if reply-to
(db:status-id->username reply-to)
(_ "none")))
(label-reply-raw (_ "Reply to: "))
(label-subject-raw (_ "Subject:"))
(label-visibility-raw (_ "Visibility:"))
(label-reply-length-raw (length label-reply-raw))
(label-subject-raw-length (length label-subject-raw))
(label-visibility-raw-length (length label-visibility-raw))
(max-field-length (max label-reply-length-raw
label-subject-raw-length
label-visibility-raw-length))
(label-subject (text-utils:right-padding label-subject-raw
max-field-length))
(label-reply (text-utils:right-padding label-reply-raw
max-field-length))
(label-visibility (text-utils:right-padding label-visibility-raw
max-field-length))
(value-max-length (- (win-width-no-border object)
max-field-length))
(label-attachments (_ "Attachments")))
(flet ((print-field (text x y bg fg &key (inverse nil))
(print-text object text x y
:bgcolor (if inverse
fg
bg)
:fgcolor (if inverse
bg
fg))))
(print-field label-reply 1 1 bgcolor fgcolor)
(print-field (right-padding user
value-max-length)
max-field-length
1
input-bg input-fg)
(print-field label-subject 1 2 bgcolor fgcolor)
(print-field (right-padding subject
value-max-length)
max-field-length
2
input-bg input-fg)
(print-field label-visibility 1 3 bgcolor fgcolor)
(print-field (right-padding visibility
value-max-length)
max-field-length
3
input-bg input-fg)
(print-field (right-padding (text-ellipsize label-attachments
(win-width-no-border object))
(win-width-no-border object))
1
4
bgcolor fgcolor
:inverse t)))))))
(defun init (message-data screen)
(flet ((make-rows (data bg fg)
(mapcar #'(lambda (a)
(make-instance 'line
:normal-text a
:selected-text a
:normal-bg bg
:normal-fg fg
:selected-bg fg
:selected-fg bg))
data)))
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
(setf *send-message-window*
(make-instance 'confirm-sending-window
:uses-border-p t
:screen screen
:keybindings keybindings:*send-message-keymap*
:croatoan-window low-level-window
:message-data message-data))
(refresh-config *send-message-window*)
(setf (rows *send-message-window*)
(make-rows (attachments message-data)
(bgcolor low-level-window)
(fgcolor low-level-window)))
(setf (row-selected-index *send-message-window*) 0)
*send-message-window*)))

895
src/software-configuration.lisp Normal file
View File

@ -0,0 +1,895 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/][http://www.gnu.org/licenses/]].
(in-package :software-configuration)
;; CONFIG := (ENTRIES)*
;; ENTRIES := COMMENT*
;; (USE-FILE
;; | COLOR-RE-ASSIGN
;; | SERVER-ASSIGN
;; | USERNAME-ASSIGN
;; | GENERIC-ASSIGN)
;; COMMENT*
;; SERVER-ASSIGN := SERVER-KEY BLANKS ASSIGN BLANKS GENERIC-VALUE BLANKS
;; USERNAME-ASSIGN := USERNAME-KEY BLANKS ASSIGN BLANKS GENERIC-VALUE BLANKS
;; GENERIC-ASSIGN := (and key blanks assign blanks
;; (or quoted-string
;; hexcolor
;; colorname
;; generic-value) ; the order in this list *is* important
;; blanks)
;; COLOR-RE-ASSIGN := COLOR-RE-KEY ASSIGN REGEXP FG-COLOR (? ATTRIBUTE-VALUE)
;; USE-FILE := (AND USE BLANKS FILEPATH BLANKS)
;; KEY := FIELD (FIELD-SEPARATOR KEY)*
;; BLANKS := (BLANK)*
;; FILEPATH := QUOTED-STRING
;; USE := "use"
;; SERVER-KEY := "server"
;; USERNAME-KEY := "username"
;; COLOR-RE-KEY := "color-regexp"
;; REGEXP := QUOTED-STRING
;; QUOTED-STRING := #\" (not #\") #\"
;; FIELD := ( (or ESCAPED-CHARACTER
;; (not #\# ASSIGN BLANK FIELD-SEPARATOR) )*
;; COMMENT := BLANKS #\# (not #\Newline)* BLANKS
;; FIELD-SEPARATOR := #\.
;; GENERIC-VALUE := KEY
;; ASSIGN := #\=
;; BLANK := (or #\space #\Newline #\Tab)
;; BG-COLOR := COLOR
;; FG-COLOR := COLOR
;; COLOR := HEX-COLOR | COLOR-NAME
;; HEX-COLOR := HEXCOLOR-PREFIX
;; HEXDIGIT HEXDIGIT -> red
;; HEXDIGIT HEXDIGIT -> green
;; HEXDIGIT HEXDIGIT -> blue
;; ESCAPED-CHARACTER := #\\ any-character
;; HEXCOLOR-PREFIX := #\#
;; HEX-DIGIT := (and (character-ranges #\0 #\9)
;; (character-ranges #\a #\f)
;; (character-ranges #\A #\f)
;; ATTRIBUTE-VALUE := "bold"
;; | "italic"
;; | "underline"
;; | "blink"
;; COLOR-NAME := "black"
;; | "red"
;; | "green"
;; | "yellow"
;; | "blue"
;; | "magenta"
;; | "cyan"
;; | "white"
(define-constant +conf-filename+ "main.conf" :test #'string=)
(define-constant +field-separator-value+ "." :test #'string=)
(define-constant +field-separator+ :field-separator :test #'eq)
(defrule blank (or #\space #\Newline #\Tab)
(:constant nil))
(defrule blanks (* blank)
(:constant nil))
(defrule assign #\=
(:constant nil))
(defrule comment (and blanks #\# (* (not #\Newline)) blanks)
(:constant nil))
(defrule hexcolor-prefix #\#)
(defrule hex-digit
(or (character-ranges (#\0 #\9))
(character-ranges (#\a #\f))
(character-ranges (#\A #\F))))
(defrule hexcolor
(and hexcolor-prefix
hex-digit hex-digit ; r
hex-digit hex-digit ; g
hex-digit hex-digit) ; b
(:text t)
(:function (lambda (a) (parse-integer a :start 1 :radix 16))))
(defun keywordize (a)
(make-keyword (string-upcase a)))
(defrule colorname
(or "black"
"red"
"green"
"yellow"
"blue"
"magenta"
"cyan"
"white")
(:function keywordize))
(defrule escaped-character (and #\\ character)
(:function (lambda (a) (list (second a)))))
(defrule field-separator #\.)
(defrule field
(* (or escaped-character
(not (or #\# assign field-separator blank))))
(:text t))
;; this rule is not actually part of the grammar but jus a convenience
;; function to remove duplicated code (see rules: key and value)
(defrule fields
(and field
(? (and field-separator fields)))
(:function flatten))
(defrule key fields
(:function (lambda (a)
(mapcar (lambda (element)
(if (string= +field-separator-value+ element)
nil
(format-keyword element)))
a)))
(:function remove-if-null))
(defrule generic-value fields
(:text t))
(defrule generic-assign
(and key blanks assign blanks
(or quoted-string
hexcolor
colorname
generic-value) ; the order in this list *is* important
blanks)
(:function remove-if-null))
(defrule quoted-string (and #\" (+ (not #\")) #\")
(:function (lambda (a) (second a)))
(:text t))
(defrule regexp quoted-string)
(defrule color-re-key "color-regexp"
(:constant :color-re))
(defclass color-re-assign ()
((re
:initform nil
:initarg :re
:accessor re)
(color-name
:initform nil
:initarg :color-name
:accessor color-name)
(color-value
:initform nil
:initarg :color-value
:accessor color-value)
(attributes
:initform nil
:initarg :attributes
:accessor attributes))
(:documentation "A color assign based on a regular expression. Slots
color-name and color-value are mutually exclusive"))
(defmethod print-object ((object color-re-assign) stream)
(print-unreadable-object (object stream :type t :identity nil)
(with-accessors ((re re)
(color-name color-name)
(color-value color-value)
(attributes attributes)) object
(format stream "re: ~s colorname: ~s colorvalue: ~s attributes ~a"
re color-name color-value attributes))))
(defun make-color-re-assign (re color-name color-value attributes)
(assert (and (or color-name
color-value)
(or (null color-name)
(null color-value))))
(make-instance 'color-re-assign
:re re
:color-name color-name
:color-value color-value
:attributes attributes))
(defun build-color-re-assign (parsed)
(let* ((clean (remove-if-null parsed))
(re (second parsed))
(color (third parsed))
(color-name-p (keywordp color))
(attributes (first (fourth parsed))))
(list (first clean)
(make-color-re-assign re
(and color-name-p color)
(and (not color-name-p) color)
attributes))))
(defrule attribute-value (or "bold"
"italic"
"underline"
"blink")
(:text t)
(:function tui-utils:text->tui-attribute))
(defrule color-re-assign
(and color-re-key blanks
assign blanks regexp blanks
(or hexcolor colorname) blanks
(? (and attribute-value blanks)))
(:function remove-if-null)
(:function build-color-re-assign))
(defrule server-key "server"
(:constant :server))
(defrule username-key "username"
(:constant :username))
(defrule server-assign
(and server-key blanks assign blanks generic-value blanks)
(:function remove-if-null))
(defrule username-assign
(and username-key blanks assign blanks generic-value blanks)
(:function remove-if-null))
(defrule filepath quoted-string)
(defparameter *already-included-files* ())
(defrule use-file (and "use" blanks filepath blanks)
(:function (lambda (a)
(let ((file (third a)))
(if (find file *already-included-files* :test #'string=)
(error "Cyclic include of file ~s detected" file)
(progn
(push file *already-included-files*)
(load-config-file (third a))))
nil))))
(defrule entries
(and (* comment)
(or use-file
color-re-assign
server-assign
username-assign
generic-assign)
(* comment))
(:function second))
(defrule config (* entries)
(:function remove-if-null))
(defgeneric parse-config (object))
(defmethod parse-config ((object string))
(parse 'config object))
(defmethod parse-config ((object pathname))
(parse-config (fs:slurp-file object)))
(defparameter *software-configuration* ())
(defmacro gen-key-constant (name)
`(define-constant ,(format-fn-symbol t "+key-~a+" name)
,(format-keyword name)
:test #'eq))
(defmacro gen-key-constants (&rest names)
`(progn
,@(loop for name in names collect
`(gen-key-constant ,name))))
(gen-key-constants background
foreground
title
start
end
left
right
stopper
width
height
error
info
window
header
focus
prefix
postfix
value
attribute
new-message
mark
crypted
histogram
error-dialog
info-dialog
input-dialog
help-dialog
notify-window
life
quick-help
more-choices
modeline
date-format
locked
unlocked
account
main-window
thread-window
message-window
attachment-header
max-numbers-allowed-attachments
max-message-length
max-report-comment-length
reply-quoted-character
line-position-mark
favourite
sensitive
boosted
tags-window
conversations-window
keybindings-window
suggestions-window
open-attach-window
command-window
command-separator
tree
branch
arrow
data
data-leaf
leaf
branch
spacer
vertical-line
editor
username
server
message
selected
deleted
input
read
unread
color-re
purge-history-days-offset
purge-cache-days-offset)
(defun load-config-file (&optional (virtual-filepath +conf-filename+))
(let* ((file (res:get-config-file virtual-filepath))
(tree (parse-config (fs:namestring->pathname file))))
(loop for entry in tree do
(let ((key (first entry))
(value (second entry)))
(cond
((eq +key-color-re+ key)
(setf (access:accesses *software-configuration* key)
(append (access:accesses *software-configuration* key)
(list value))))
((keywordp key)
(setf (access:accesses *software-configuration* key) value))
(t
(multiple-value-bind (rest all)
(apply #'access:set-accesses value *software-configuration* key)
(declare (ignore rest))
(setf *software-configuration* all))))))
*software-configuration*))
;;;; end of parser
(defparameter *allowed-status-visibility* '("public" "unlisted" "private" "direct")
"- public Visible to everyone, shown in public timelines;
- unlisted Visible to public, but not included in public timelines;
- private Visible to followers only, and to any mentioned users;
- direct Visible only to mentioned users.")
(defparameter *allowed-attachment-type* '("unknown" "image" "gifv" "video" "audio"))
;;;; interface
(defun crypted-mark-value ()
(or (access:accesses *software-configuration*
+key-crypted+
+key-mark+
+key-value+)
(_ "This message was crypted.")))
(defun quick-help-header-colors ()
(values (access:accesses *software-configuration*
+key-quick-help+
+key-header+
+key-background+)
(access:accesses *software-configuration*
+key-quick-help+
+key-header+
+key-foreground+)
(tui-utils:text->tui-attribute (access:accesses *software-configuration*
+key-quick-help+
+key-header+
+key-attribute+))))
(defun window-titles-end (side)
(assert (member side (list +key-left+ +key-right+)))
(access:accesses *software-configuration*
+key-window+
+key-title+
side
+key-stopper+
+key-value+))
(defun window-titles-ends ()
(multiple-value-bind (x y focus-value)
(config-win-focus-mark)
(declare (ignore x y))
(values (window-titles-end +key-left+)
(window-titles-end +key-right+)
(+ 2 (length focus-value)))))
(defun tags-histogram-foreground ()
(access:accesses *software-configuration*
+key-tags-window+
+key-histogram+
+key-foreground+))
(defun tags-new-message-mark ()
(access:accesses *software-configuration*
+key-tags-window+
+key-new-message+
+key-mark+
+key-value+))
(defun conversation-window-message-count-colors (key-read/unread)
(values (access:accesses *software-configuration*
+key-conversations-window+
key-read/unread
+key-foreground+)
(access:accesses *software-configuration*
+key-conversations-window+
key-read/unread
+key-background+)))
(defun conversation-window-read-colors ()
(multiple-value-bind (fg bg)
(conversation-window-message-count-colors +key-read+)
(values fg bg)))
(defun conversation-window-unread-colors ()
(multiple-value-bind (fg bg)
(conversation-window-message-count-colors +key-unread+)
(values fg bg)))
(defun max-message-length ()
(num:parse-number-default (access:accesses *software-configuration*
+key-max-message-length+)
500))
(defun max-report-comment-length ()
(num:parse-number-default (access:accesses *software-configuration*
+key-max-report-comment-length+)
100))
(defun quote-char ()
(or (access:accesses *software-configuration*
+key-reply-quoted-character+)
"> "))
(defun max-attachments-allowed ()
(num:parse-number-default (access:accesses *software-configuration*
+key-max-numbers-allowed-attachments+)
4))
(defun external-editor ()
(access:accesses *software-configuration*
+key-editor+))
(defun color-regexps ()
(access:accesses *software-configuration*
+key-color-re+))
(defmacro gen-win-key-access (fn-suffix key)
`(defun ,(misc:format-fn-symbol t "win-~a" fn-suffix) (win-key)
(access:accesses *software-configuration*
win-key
,key)))
(gen-win-key-access bg +key-background+)
(gen-win-key-access fg +key-foreground+)
(gen-win-key-access height +key-height+)
(gen-win-key-access width +key-width+)
(defmacro gen-simple-access ((fn-name &key (transform-value-fn 'identity)) &rest keys)
`(defun ,(misc:format-fn-symbol t "config-~a" fn-name) ()
(,transform-value-fn (access:accesses *software-configuration*
,@keys))))
(gen-simple-access (purge-history-days-offset
:transform-value-fn
(lambda (a)
(num:safe-parse-number a
:fix-fn (lambda (e)
(declare (ignore e))
100))))
+key-purge-history-days-offset+)
(gen-simple-access (purge-cage-days-offset
:transform-value-fn
(lambda (a)
(num:safe-parse-number a
:fix-fn (lambda (e)
(declare (ignore e))
100))))
+key-purge-history-days-offset+)
(gen-simple-access (notification-life
:transform-value-fn
(lambda (a)
(num:safe-parse-number a
:fix-fn (lambda (e)
(declare (ignore e))
100))))
+key-notify-window+
+key-life+)
(gen-simple-access (server-name)
+key-server+)
(gen-simple-access (username)
+key-username+)
(defun config-win-focus-mark ()
(values (access:accesses *software-configuration*
+key-window+
+key-focus+
+key-mark+
+key-background+)
(access:accesses *software-configuration*
+key-window+
+key-focus+
+key-mark+
+key-foreground+)
(access:accesses *software-configuration*
+key-window+
+key-focus+
+key-mark+
+key-value+)))
(defun command-separator-config-values ()
(values (access:accesses *software-configuration*
+key-command-window+
+key-command-separator+
+key-background+)
(access:accesses *software-configuration*
+key-command-window+
+key-command-separator+
+key-foreground+)
(access:accesses *software-configuration*
+key-command-window+
+key-command-separator+
+key-value+)))
(defun command-error-message-colors ()
(values (access:accesses *software-configuration*
+key-command-window+
+key-error+
+key-message+
+key-background+)
(access:accesses *software-configuration*
+key-command-window+
+key-error+
+key-message+
+key-foreground+)
(tui-utils:text->tui-attribute (access:accesses *software-configuration*
+key-command-window+
+key-error+
+key-message+
+key-attribute+))))
(defun command-info-message-colors ()
(values (access:accesses *software-configuration*
+key-command-window+
+key-info+
+key-message+
+key-background+)
(access:accesses *software-configuration*
+key-command-window+
+key-info+
+key-message+
+key-foreground+)
(tui-utils:text->tui-attribute (access:accesses *software-configuration*
+key-command-window+
+key-info+
+key-message+
+key-attribute+))))
(defun tree-config-colors (tree-win-holder)
(values (access:accesses *software-configuration*
tree-win-holder
+key-tree+
+key-branch+
+key-foreground+)
(access:accesses *software-configuration*
tree-win-holder
+key-tree+
+key-arrow+
+key-foreground+)
(access:accesses *software-configuration*
tree-win-holder
+key-tree+
+key-data+
+key-foreground+)
(access:accesses *software-configuration*
tree-win-holder
+key-tree+
+key-data-leaf+
+key-foreground+)))
(defun tree-config-rendering-values (tree-win-holder)
(values (access:accesses *software-configuration*
tree-win-holder
+key-tree+
+key-arrow+
+key-value+)
(access:accesses *software-configuration*
tree-win-holder
+key-tree+
+key-leaf+
+key-value+)
(access:accesses *software-configuration*
tree-win-holder
+key-tree+
+key-branch+
+key-value+)
(access:accesses *software-configuration*
tree-win-holder
+key-tree+
+key-spacer+
+key-value+)
(access:accesses *software-configuration*
tree-win-holder
+key-tree+
+key-vertical-line+
+key-value+)))
(defun make-tree-colormap (window-key)
(let ((tree-color-map ()))
(flet ((add-color-pair (key color)
(setf tree-color-map (acons key color tree-color-map))))
(multiple-value-bind (branch-color arrow-color data-color leaf-color)
(swconf:tree-config-colors window-key)
(add-color-pair :branch branch-color)
(add-color-pair :arrow arrow-color)
(add-color-pair :data data-color)
(add-color-pair :data-leaf leaf-color))
tree-color-map)))
(defun thread-message-symbol-lookup (field key)
(access:accesses *software-configuration*
+key-thread-window+
+key-message+
field
key))
(defun thread-message-symbol-value (field)
(thread-message-symbol-lookup field +key-value+))
(defun thread-message-symbol-fg (field)
(thread-message-symbol-lookup field +key-foreground+))
(defun thread-message-symbol (field)
(values (thread-message-symbol-value field)
(thread-message-symbol-fg field)))
(defun thread-message-colors (key)
(values (access:accesses *software-configuration*
+key-thread-window+
+key-message+
key
+key-background+)
(access:accesses *software-configuration*
+key-thread-window+
+key-message+
key
+key-foreground+)
(tui-utils:text->tui-attribute (access:accesses *software-configuration*
+key-thread-window+
+key-message+
key
+key-attribute+))))
(defun thread-message-read-colors ()
(multiple-value-bind (bg fg attribute)
(thread-message-colors +key-read+)
(values bg fg attribute)))
(defun thread-message-unread-colors ()
(multiple-value-bind (bg fg attribute)
(thread-message-colors +key-unread+)
(values bg fg attribute)))
(defun thread-message-selected-colors ()
(multiple-value-bind (bg fg attribute)
(thread-message-colors +key-selected+)
(values bg fg attribute)))
(defun thread-message-deleted-colors ()
(multiple-value-bind (bg fg attribute)
(thread-message-colors +key-deleted+)
(values bg fg attribute)))
(defun modeline-colors (window-key)
(values (access:accesses *software-configuration*
window-key
+key-modeline+
+key-background+)
(access:accesses *software-configuration*
window-key
+key-modeline+
+key-foreground+)))
(defun modeline-fmt (window-key)
(access:accesses *software-configuration*
window-key
+key-modeline+
+key-value+))
(defun date-fmt (window-key)
(let* ((raw (access:accesses *software-configuration*
window-key
+key-date-format+
+key-value+)))
(date-formatter:expand-date-formatter-spec raw)))
(defun locked/unlocked-value (key-window locked)
(let ((key-locked (if locked
+key-locked+
+key-unlocked+)))
(access:accesses *software-configuration*
key-window
key-locked
+key-value+)))
(defun locked/unlocked-account-mark-value (key-window locked)
(let ((key-locked (if locked
+key-locked+
+key-unlocked+)))
(access:accesses *software-configuration*
key-window
+key-account+
key-locked
+key-mark+
+key-value+)))
(defun message-window-locked-account-mark ()
(locked/unlocked-account-mark-value +key-message-window+ t))
(defun message-window-unlocked-account-mark ()
(locked/unlocked-account-mark-value +key-message-window+ nil))
(defun message-window-account-locking-status-mark (locking-value)
(if locking-value
(message-window-locked-account-mark)
(message-window-unlocked-account-mark)))
(defun message-window-line-mark-values ()
"return three values: mark string fg and bg"
(values (access:accesses *software-configuration*
+key-message-window+
+key-line-position-mark+
+key-value+)
(access:accesses *software-configuration*
+key-message-window+
+key-line-position-mark+
+key-foreground+)
(access:accesses *software-configuration*
+key-message-window+
+key-line-position-mark+
+key-background+)))
(defun message-window-attachments-header ()
(values (access:accesses *software-configuration*
+key-message-window+
+key-attachment-header+
+key-prefix+
+key-value+)
(access:accesses *software-configuration*
+key-message-window+
+key-attachment-header+
+key-postfix+
+key-value+)
(access:accesses *software-configuration*
+key-message-window+
+key-attachment-header+
+key-value+)))
(defclass form-style ()
((background
:initform :black
:initarg :background
:accessor background)
(foreground
:initform :white
:initarg :foreground
:accessor foreground)
(input-background
:initform :black
:initarg :input-background
:accessor input-background)
(input-foreground
:initform :white
:initarg :input-foreground
:accessor input-foreground)
(selected-background
:initform :black
:initarg :selected-background
:accessor selected-background)
(selected-foreground
:initform :white
:initarg :selected-foreground
:accessor selected-foreground)))
(defmethod print-object ((object form-style) stream)
(print-unreadable-object (object stream :type t)
(with-accessors ((background background)
(foreground foreground)
(input-background input-background)
(input-foreground input-foreground)
(selected-background selected-background)
(selected-foreground selected-foreground)) object
(format stream
"fg ~a bg ~a input-fg ~a input-bg ~a selected-fg ~a selected-bg ~a"
foreground
background
input-foreground
input-background
selected-foreground
selected-background))))
(defun form-style (window-key)
(make-instance 'form-style
:background (access:accesses *software-configuration*
window-key
+key-background+)
:foreground (access:accesses *software-configuration*
window-key
+key-foreground+)
:selected-background (access:accesses *software-configuration*
window-key
+key-input+
+key-selected+
+key-background+)
:selected-foreground (access:accesses *software-configuration*
window-key
+key-input+
+key-selected+
+key-foreground+)
:input-background (access:accesses *software-configuration*
window-key
+key-input+
+key-background+)
:input-foreground (access:accesses *software-configuration*
window-key
+key-input+
+key-foreground+)))

50
src/specials.lisp Normal file
View File

@ -0,0 +1,50 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :specials)
(defparameter *main-window* nil
"The main window of the program. AKA the screen")
(defparameter *keybindings-suggestions-window* nil
"The window to show suggestions for keybindings.")
(defparameter *strings-suggestions-window* nil
"The window to show suggestions for keybindings.")
(defparameter *command-window* nil
"The window to deal with user key input.")
(defparameter *thread-window* nil
"The threaded messages window.")
(defparameter *message-window* nil
"The window where a single message is rendered.")
(defparameter *send-message-window* nil
"The window shown to confirm sending a new message.")
(defparameter *follow-requests-window* nil
"The window shown to accept follow requests.")
(defparameter *tags-window* nil
"The window shown to manage tags subscriptions.")
(defparameter *conversations-window* nil
"The window that shows conversations.")
(defparameter *open-attach-window* nil
"The window that shows attachments for a message.")

45
src/stack.lisp Normal file
View File

@ -0,0 +1,45 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :stack)
(defparameter *stack* (misc:make-array-frame 0))
(defparameter *equal-function* #'equalp)
(defparameter *key-function* #'identity)
(defun push (val)
(vector-push-extend val *stack*))
(defun pop ()
(if (not (emptyp))
(prog1
(alexandria:last-elt *stack*)
(setf *stack* (misc:safe-delete@ *stack* (1- (length *stack*)))))
nil))
(defun find (element)
(cl:find element *stack* :key *key-function* :test *equal-function*))
(defun emptyp ()
(not (> (length *stack*) 0)))
(defmacro with-stack ((equal key) &body body)
`(let ((*stack* (misc:make-array-frame 0))
(*equal-function* ,equal)
(*key-function* ,key))
,@body))

52
src/suggestions-window.lisp Normal file
View File

@ -0,0 +1,52 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2018 cage
;; 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/>.
(in-package :suggestions-window)
(defclass suggestions-window (wrapper-window)
((paginated-info
:initform nil
:initarg :paginated-info
:accessor paginated-info)
(current-page
:initform 0
:initarg :current-page
:accessor current-page)))
(defun draw-pagination-info (win)
(with-accessors ((paginated-info paginated-info)
(current-page current-page)) win
(let* ((msg (format nil
(_ "Page ~a of ~a")
(1+ current-page)
(length paginated-info)))
(msg-x (calc-center-on-window-width win msg))
(msg-y (calc-bottom-of-window-height win)))
(print-text win msg msg-x msg-y))))
(defmethod refresh-config :after ((object suggestions-window))
(with-croatoan-window (croatoan-window object)
(refresh-config-colors object swconf:+key-suggestions-window+)
(refresh-config-sizes object swconf:+key-suggestions-window+)
(let ((y (- (win-height *main-window*)
(win-height object)
+command-window-height+)))
(win-move object 0 y))))
(defmethod draw ((object suggestions-window))
(win-raise-to-top object))
(defgeneric update-suggestions (object hint &key &allow-other-keys))

150
src/tags-window.lisp Normal file
View File

@ -0,0 +1,150 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :tags-window)
(defclass tags-window (focus-marked-window
simple-line-navigation-window
title-window
border-window)
((new-messages-mark
:initarg :new-messages-mark
:initform ()
:accessor new-messages-mark)
(histogram-fg
:initarg :histogram-fg
:initform ()
:accessor histogram-fg)))
(defmethod refresh-config :after ((object tags-window))
(with-accessors ((croatoan-window croatoan-window)
(histogram-fg histogram-fg)
(selected-line-bg selected-line-bg)
(selected-line-fg selected-line-fg)
(new-messages-mark new-messages-mark)) object
(let* ((theme-style (swconf:form-style swconf:+key-tags-window+))
(fg (swconf:foreground theme-style))
(bg (swconf:background theme-style))
(selected-fg (swconf:selected-foreground theme-style))
(selected-bg (swconf:selected-background theme-style))
(new-message-value (swconf:tags-new-message-mark))
(width (- (win-width *main-window*)
(win-width *thread-window*)))
(raw-height (swconf:win-height swconf:+key-tags-window+))
(height (main-window:parse-subwin-h raw-height))
(y 0)
(x 0))
(setf selected-line-fg selected-fg)
(setf selected-line-bg selected-bg)
(setf new-messages-mark new-message-value)
(setf histogram-fg (swconf:tags-histogram-foreground))
(setf (background croatoan-window)
(tui:make-background bg))
(setf (bgcolor croatoan-window) bg)
(setf (fgcolor croatoan-window) fg)
(win-resize object width height)
(win-move object x y)
object)))
(defmethod draw :before ((object tags-window))
(with-accessors ((rows rows)
(histogram-fg histogram-fg)
(single-row-height single-row-height)
(top-row-padding top-row-padding)
(new-messages-mark new-messages-mark)) object
(win-clear object)
(with-croatoan-window (croatoan-window object)
(let ((histogram-width (- (win-width-no-border object)
(length new-messages-mark))))
(loop
for y from (+ 2 top-row-padding) by single-row-height
for row-fields in (mapcar #'fields rows) do
(let* ((histogram-data (fields-histogram row-fields))
(length-histogram-data (length histogram-data))
(histogram-visualized-data (safe-subseq histogram-data
(- length-histogram-data
histogram-width)
length-histogram-data))
(histogram (cl-spark:spark histogram-visualized-data))
(got-new-messages-p (getf row-fields :got-new-message-p)))
(print-text object
histogram
1 y
:bgcolor (bgcolor croatoan-window)
:fgcolor histogram-fg)
(when got-new-messages-p
(print-text object new-messages-mark nil nil
:bgcolor (bgcolor croatoan-window)
:fgcolor histogram-fg))))))))
(defmethod resync-rows-db ((object tags-window) &key (redraw t) (suggested-message-index nil))
(with-accessors ((rows rows)
(selected-line-bg selected-line-bg)
(selected-line-fg selected-line-fg)) object
(flet ((make-rows (line-fields bg fg)
(mapcar (lambda (fields)
(let ((text (db:tag->folder-name (fields-tag fields))))
(make-instance 'line
:fields fields
:normal-text text
:selected-text text
:normal-bg bg
:normal-fg fg
:selected-bg fg
:selected-fg bg)))
line-fields)))
(let ((line-fields (make-tag-line-fields)))
(setf rows (make-rows line-fields
selected-line-bg
selected-line-fg))
(when suggested-message-index
(select-row object suggested-message-index))
(when redraw
(draw object))))))
(defun fields-tag (fields)
(getf fields :tag))
(defun fields-histogram (fields)
(getf fields :histogram))
(defun make-tag-line-fields ()
(let* ((all-tags-name (db:all-subscribed-tags-name :sort-data t))
(all-tags (db:all-subscribed-tags :sort-data t))
(all-histograms (loop for tag-name in all-tags-name collect
(db:tag-histogram tag-name))))
(loop
for tag in all-tags
for histogram in all-histograms collect
(list :tag (db:row-id tag)
:got-new-message-p (db:row-tag-got-new-message tag)
:histogram histogram))))
(defun init ()
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
(setf *tags-window*
(make-instance 'tags-window
:title (_ "Subscribed tags")
:single-row-height 3
:uses-border-p t
:keybindings keybindings:*tags-keymap*
:croatoan-window low-level-window))
(refresh-config *tags-window*)
(resync-rows-db *tags-window* :redraw nil)
(when (rows *tags-window*)
(select-row *tags-window* 0))
(draw *tags-window*)
*tags-window*))

22
src/tests/all-tests.lisp Normal file
View File

@ -0,0 +1,22 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/>.
(in-package :all-tests)
(defsuite all-suite ())
(defun run-all-tests (&key (use-debugger nil))
(clunit:run-suite 'all-suite :use-debugger use-debugger))

54
src/tests/box-tests.lisp Normal file
View File

@ -0,0 +1,54 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/][http://www.gnu.org/licenses/]].
(in-package :box-tests)
(defsuite box-suite (all-suite))
(defun shared-boxes ()
(let ((contents (vector nil)))
(values (box contents)
(box contents))))
(deftest test-unbox (box-suite)
(assert-true (numberp (unbox 1)))
(assert-true (= (unbox 1) (unbox 1))))
(deftest test-shared (box-suite)
(multiple-value-bind (box-1 box-2)
(shared-boxes)
(assert-false (eq box-1 box-2))
(assert-true (eq (unbox box-1) (unbox box-2)))
(assert-true (eq (unbox 1) (unbox 1)))))
(defun shared-dboxes ()
(let ((contents (vector 'a)))
(values (dbox contents)
(dbox contents))))
(deftest test-dbox-shared (box-suite)
(multiple-value-bind (dbox-1 dbox-2)
(shared-dboxes)
(assert-false (eq dbox-1 dbox-2))
(assert-true (eq (dunbox dbox-1) (dunbox dbox-2)))
(assert-true
(progn
(setf (unbox dbox-1) (unbox dbox-2))
(setf (dunbox dbox-1) "foo")
(eq (dunbox dbox-1)
(dunbox dbox-2)))
(format nil "~a ~a" dbox-1 dbox-2))))

25
src/tests/misc-tests.lisp Normal file
View File

@ -0,0 +1,25 @@
;; tinmop: an humble mastodon client
;; Copyright (C) 2020 cage
;; 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/][http://www.gnu.org/licenses/]].
(in-package :misc-tests)
(defsuite misc-suite (all-suite))
(deftest test-shuffle (misc-suite)
(assert-true
(let ((bag (loop repeat 1000 collect (num:lcg-next-upto 1000))))
(null (set-difference bag (shuffle bag))))))

Some files were not shown because too many files have changed in this diff Show More