├── .gitignore
├── LICENSE
├── README.md
├── bfs.el
└── bfs.png
/.gitignore:
--------------------------------------------------------------------------------
1 | test/
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | GNU GENERAL PUBLIC LICENSE
2 | Version 3, 29 June 2007
3 |
4 | Copyright (C) 2007 Free Software Foundation, Inc.
5 | Everyone is permitted to copy and distribute verbatim copies
6 | of this license document, but changing it is not allowed.
7 |
8 | Preamble
9 |
10 | The GNU General Public License is a free, copyleft license for
11 | software and other kinds of works.
12 |
13 | The licenses for most software and other practical works are designed
14 | to take away your freedom to share and change the works. By contrast,
15 | the GNU General Public License is intended to guarantee your freedom to
16 | share and change all versions of a program--to make sure it remains free
17 | software for all its users. We, the Free Software Foundation, use the
18 | GNU General Public License for most of our software; it applies also to
19 | any other work released this way by its authors. You can apply it to
20 | your programs, too.
21 |
22 | When we speak of free software, we are referring to freedom, not
23 | price. Our General Public Licenses are designed to make sure that you
24 | have the freedom to distribute copies of free software (and charge for
25 | them if you wish), that you receive source code or can get it if you
26 | want it, that you can change the software or use pieces of it in new
27 | free programs, and that you know you can do these things.
28 |
29 | To protect your rights, we need to prevent others from denying you
30 | these rights or asking you to surrender the rights. Therefore, you have
31 | certain responsibilities if you distribute copies of the software, or if
32 | you modify it: responsibilities to respect the freedom of others.
33 |
34 | For example, if you distribute copies of such a program, whether
35 | gratis or for a fee, you must pass on to the recipients the same
36 | freedoms that you received. You must make sure that they, too, receive
37 | or can get the source code. And you must show them these terms so they
38 | know their rights.
39 |
40 | Developers that use the GNU GPL protect your rights with two steps:
41 | (1) assert copyright on the software, and (2) offer you this License
42 | giving you legal permission to copy, distribute and/or modify it.
43 |
44 | For the developers' and authors' protection, the GPL clearly explains
45 | that there is no warranty for this free software. For both users' and
46 | authors' sake, the GPL requires that modified versions be marked as
47 | changed, so that their problems will not be attributed erroneously to
48 | authors of previous versions.
49 |
50 | Some devices are designed to deny users access to install or run
51 | modified versions of the software inside them, although the manufacturer
52 | can do so. This is fundamentally incompatible with the aim of
53 | protecting users' freedom to change the software. The systematic
54 | pattern of such abuse occurs in the area of products for individuals to
55 | use, which is precisely where it is most unacceptable. Therefore, we
56 | have designed this version of the GPL to prohibit the practice for those
57 | products. If such problems arise substantially in other domains, we
58 | stand ready to extend this provision to those domains in future versions
59 | of the GPL, as needed to protect the freedom of users.
60 |
61 | Finally, every program is threatened constantly by software patents.
62 | States should not allow patents to restrict development and use of
63 | software on general-purpose computers, but in those that do, we wish to
64 | avoid the special danger that patents applied to a free program could
65 | make it effectively proprietary. To prevent this, the GPL assures that
66 | patents cannot be used to render the program non-free.
67 |
68 | The precise terms and conditions for copying, distribution and
69 | modification follow.
70 |
71 | TERMS AND CONDITIONS
72 |
73 | 0. Definitions.
74 |
75 | "This License" refers to version 3 of the GNU General Public License.
76 |
77 | "Copyright" also means copyright-like laws that apply to other kinds of
78 | works, such as semiconductor masks.
79 |
80 | "The Program" refers to any copyrightable work licensed under this
81 | License. Each licensee is addressed as "you". "Licensees" and
82 | "recipients" may be individuals or organizations.
83 |
84 | To "modify" a work means to copy from or adapt all or part of the work
85 | in a fashion requiring copyright permission, other than the making of an
86 | exact copy. The resulting work is called a "modified version" of the
87 | earlier work or a work "based on" the earlier work.
88 |
89 | A "covered work" means either the unmodified Program or a work based
90 | on the Program.
91 |
92 | To "propagate" a work means to do anything with it that, without
93 | permission, would make you directly or secondarily liable for
94 | infringement under applicable copyright law, except executing it on a
95 | computer or modifying a private copy. Propagation includes copying,
96 | distribution (with or without modification), making available to the
97 | public, and in some countries other activities as well.
98 |
99 | To "convey" a work means any kind of propagation that enables other
100 | parties to make or receive copies. Mere interaction with a user through
101 | a computer network, with no transfer of a copy, is not conveying.
102 |
103 | An interactive user interface displays "Appropriate Legal Notices"
104 | to the extent that it includes a convenient and prominently visible
105 | feature that (1) displays an appropriate copyright notice, and (2)
106 | tells the user that there is no warranty for the work (except to the
107 | extent that warranties are provided), that licensees may convey the
108 | work under this License, and how to view a copy of this License. If
109 | the interface presents a list of user commands or options, such as a
110 | menu, a prominent item in the list meets this criterion.
111 |
112 | 1. Source Code.
113 |
114 | The "source code" for a work means the preferred form of the work
115 | for making modifications to it. "Object code" means any non-source
116 | form of a work.
117 |
118 | A "Standard Interface" means an interface that either is an official
119 | standard defined by a recognized standards body, or, in the case of
120 | interfaces specified for a particular programming language, one that
121 | is widely used among developers working in that language.
122 |
123 | The "System Libraries" of an executable work include anything, other
124 | than the work as a whole, that (a) is included in the normal form of
125 | packaging a Major Component, but which is not part of that Major
126 | Component, and (b) serves only to enable use of the work with that
127 | Major Component, or to implement a Standard Interface for which an
128 | implementation is available to the public in source code form. A
129 | "Major Component", in this context, means a major essential component
130 | (kernel, window system, and so on) of the specific operating system
131 | (if any) on which the executable work runs, or a compiler used to
132 | produce the work, or an object code interpreter used to run it.
133 |
134 | The "Corresponding Source" for a work in object code form means all
135 | the source code needed to generate, install, and (for an executable
136 | work) run the object code and to modify the work, including scripts to
137 | control those activities. However, it does not include the work's
138 | System Libraries, or general-purpose tools or generally available free
139 | programs which are used unmodified in performing those activities but
140 | which are not part of the work. For example, Corresponding Source
141 | includes interface definition files associated with source files for
142 | the work, and the source code for shared libraries and dynamically
143 | linked subprograms that the work is specifically designed to require,
144 | such as by intimate data communication or control flow between those
145 | subprograms and other parts of the work.
146 |
147 | The Corresponding Source need not include anything that users
148 | can regenerate automatically from other parts of the Corresponding
149 | Source.
150 |
151 | The Corresponding Source for a work in source code form is that
152 | same work.
153 |
154 | 2. Basic Permissions.
155 |
156 | All rights granted under this License are granted for the term of
157 | copyright on the Program, and are irrevocable provided the stated
158 | conditions are met. This License explicitly affirms your unlimited
159 | permission to run the unmodified Program. The output from running a
160 | covered work is covered by this License only if the output, given its
161 | content, constitutes a covered work. This License acknowledges your
162 | rights of fair use or other equivalent, as provided by copyright law.
163 |
164 | You may make, run and propagate covered works that you do not
165 | convey, without conditions so long as your license otherwise remains
166 | in force. You may convey covered works to others for the sole purpose
167 | of having them make modifications exclusively for you, or provide you
168 | with facilities for running those works, provided that you comply with
169 | the terms of this License in conveying all material for which you do
170 | not control copyright. Those thus making or running the covered works
171 | for you must do so exclusively on your behalf, under your direction
172 | and control, on terms that prohibit them from making any copies of
173 | your copyrighted material outside their relationship with you.
174 |
175 | Conveying under any other circumstances is permitted solely under
176 | the conditions stated below. Sublicensing is not allowed; section 10
177 | makes it unnecessary.
178 |
179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
180 |
181 | No covered work shall be deemed part of an effective technological
182 | measure under any applicable law fulfilling obligations under article
183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or
184 | similar laws prohibiting or restricting circumvention of such
185 | measures.
186 |
187 | When you convey a covered work, you waive any legal power to forbid
188 | circumvention of technological measures to the extent such circumvention
189 | is effected by exercising rights under this License with respect to
190 | the covered work, and you disclaim any intention to limit operation or
191 | modification of the work as a means of enforcing, against the work's
192 | users, your or third parties' legal rights to forbid circumvention of
193 | technological measures.
194 |
195 | 4. Conveying Verbatim Copies.
196 |
197 | You may convey verbatim copies of the Program's source code as you
198 | receive it, in any medium, provided that you conspicuously and
199 | appropriately publish on each copy an appropriate copyright notice;
200 | keep intact all notices stating that this License and any
201 | non-permissive terms added in accord with section 7 apply to the code;
202 | keep intact all notices of the absence of any warranty; and give all
203 | recipients a copy of this License along with the Program.
204 |
205 | You may charge any price or no price for each copy that you convey,
206 | and you may offer support or warranty protection for a fee.
207 |
208 | 5. Conveying Modified Source Versions.
209 |
210 | You may convey a work based on the Program, or the modifications to
211 | produce it from the Program, in the form of source code under the
212 | terms of section 4, provided that you also meet all of these conditions:
213 |
214 | a) The work must carry prominent notices stating that you modified
215 | it, and giving a relevant date.
216 |
217 | b) The work must carry prominent notices stating that it is
218 | released under this License and any conditions added under section
219 | 7. This requirement modifies the requirement in section 4 to
220 | "keep intact all notices".
221 |
222 | c) You must license the entire work, as a whole, under this
223 | License to anyone who comes into possession of a copy. This
224 | License will therefore apply, along with any applicable section 7
225 | additional terms, to the whole of the work, and all its parts,
226 | regardless of how they are packaged. This License gives no
227 | permission to license the work in any other way, but it does not
228 | invalidate such permission if you have separately received it.
229 |
230 | d) If the work has interactive user interfaces, each must display
231 | Appropriate Legal Notices; however, if the Program has interactive
232 | interfaces that do not display Appropriate Legal Notices, your
233 | work need not make them do so.
234 |
235 | A compilation of a covered work with other separate and independent
236 | works, which are not by their nature extensions of the covered work,
237 | and which are not combined with it such as to form a larger program,
238 | in or on a volume of a storage or distribution medium, is called an
239 | "aggregate" if the compilation and its resulting copyright are not
240 | used to limit the access or legal rights of the compilation's users
241 | beyond what the individual works permit. Inclusion of a covered work
242 | in an aggregate does not cause this License to apply to the other
243 | parts of the aggregate.
244 |
245 | 6. Conveying Non-Source Forms.
246 |
247 | You may convey a covered work in object code form under the terms
248 | of sections 4 and 5, provided that you also convey the
249 | machine-readable Corresponding Source under the terms of this License,
250 | in one of these ways:
251 |
252 | a) Convey the object code in, or embodied in, a physical product
253 | (including a physical distribution medium), accompanied by the
254 | Corresponding Source fixed on a durable physical medium
255 | customarily used for software interchange.
256 |
257 | b) Convey the object code in, or embodied in, a physical product
258 | (including a physical distribution medium), accompanied by a
259 | written offer, valid for at least three years and valid for as
260 | long as you offer spare parts or customer support for that product
261 | model, to give anyone who possesses the object code either (1) a
262 | copy of the Corresponding Source for all the software in the
263 | product that is covered by this License, on a durable physical
264 | medium customarily used for software interchange, for a price no
265 | more than your reasonable cost of physically performing this
266 | conveying of source, or (2) access to copy the
267 | Corresponding Source from a network server at no charge.
268 |
269 | c) Convey individual copies of the object code with a copy of the
270 | written offer to provide the Corresponding Source. This
271 | alternative is allowed only occasionally and noncommercially, and
272 | only if you received the object code with such an offer, in accord
273 | with subsection 6b.
274 |
275 | d) Convey the object code by offering access from a designated
276 | place (gratis or for a charge), and offer equivalent access to the
277 | Corresponding Source in the same way through the same place at no
278 | further charge. You need not require recipients to copy the
279 | Corresponding Source along with the object code. If the place to
280 | copy the object code is a network server, the Corresponding Source
281 | may be on a different server (operated by you or a third party)
282 | that supports equivalent copying facilities, provided you maintain
283 | clear directions next to the object code saying where to find the
284 | Corresponding Source. Regardless of what server hosts the
285 | Corresponding Source, you remain obligated to ensure that it is
286 | available for as long as needed to satisfy these requirements.
287 |
288 | e) Convey the object code using peer-to-peer transmission, provided
289 | you inform other peers where the object code and Corresponding
290 | Source of the work are being offered to the general public at no
291 | charge under subsection 6d.
292 |
293 | A separable portion of the object code, whose source code is excluded
294 | from the Corresponding Source as a System Library, need not be
295 | included in conveying the object code work.
296 |
297 | A "User Product" is either (1) a "consumer product", which means any
298 | tangible personal property which is normally used for personal, family,
299 | or household purposes, or (2) anything designed or sold for incorporation
300 | into a dwelling. In determining whether a product is a consumer product,
301 | doubtful cases shall be resolved in favor of coverage. For a particular
302 | product received by a particular user, "normally used" refers to a
303 | typical or common use of that class of product, regardless of the status
304 | of the particular user or of the way in which the particular user
305 | actually uses, or expects or is expected to use, the product. A product
306 | is a consumer product regardless of whether the product has substantial
307 | commercial, industrial or non-consumer uses, unless such uses represent
308 | the only significant mode of use of the product.
309 |
310 | "Installation Information" for a User Product means any methods,
311 | procedures, authorization keys, or other information required to install
312 | and execute modified versions of a covered work in that User Product from
313 | a modified version of its Corresponding Source. The information must
314 | suffice to ensure that the continued functioning of the modified object
315 | code is in no case prevented or interfered with solely because
316 | modification has been made.
317 |
318 | If you convey an object code work under this section in, or with, or
319 | specifically for use in, a User Product, and the conveying occurs as
320 | part of a transaction in which the right of possession and use of the
321 | User Product is transferred to the recipient in perpetuity or for a
322 | fixed term (regardless of how the transaction is characterized), the
323 | Corresponding Source conveyed under this section must be accompanied
324 | by the Installation Information. But this requirement does not apply
325 | if neither you nor any third party retains the ability to install
326 | modified object code on the User Product (for example, the work has
327 | been installed in ROM).
328 |
329 | The requirement to provide Installation Information does not include a
330 | requirement to continue to provide support service, warranty, or updates
331 | for a work that has been modified or installed by the recipient, or for
332 | the User Product in which it has been modified or installed. Access to a
333 | network may be denied when the modification itself materially and
334 | adversely affects the operation of the network or violates the rules and
335 | protocols for communication across the network.
336 |
337 | Corresponding Source conveyed, and Installation Information provided,
338 | in accord with this section must be in a format that is publicly
339 | documented (and with an implementation available to the public in
340 | source code form), and must require no special password or key for
341 | unpacking, reading or copying.
342 |
343 | 7. Additional Terms.
344 |
345 | "Additional permissions" are terms that supplement the terms of this
346 | License by making exceptions from one or more of its conditions.
347 | Additional permissions that are applicable to the entire Program shall
348 | be treated as though they were included in this License, to the extent
349 | that they are valid under applicable law. If additional permissions
350 | apply only to part of the Program, that part may be used separately
351 | under those permissions, but the entire Program remains governed by
352 | this License without regard to the additional permissions.
353 |
354 | When you convey a copy of a covered work, you may at your option
355 | remove any additional permissions from that copy, or from any part of
356 | it. (Additional permissions may be written to require their own
357 | removal in certain cases when you modify the work.) You may place
358 | additional permissions on material, added by you to a covered work,
359 | for which you have or can give appropriate copyright permission.
360 |
361 | Notwithstanding any other provision of this License, for material you
362 | add to a covered work, you may (if authorized by the copyright holders of
363 | that material) supplement the terms of this License with terms:
364 |
365 | a) Disclaiming warranty or limiting liability differently from the
366 | terms of sections 15 and 16 of this License; or
367 |
368 | b) Requiring preservation of specified reasonable legal notices or
369 | author attributions in that material or in the Appropriate Legal
370 | Notices displayed by works containing it; or
371 |
372 | c) Prohibiting misrepresentation of the origin of that material, or
373 | requiring that modified versions of such material be marked in
374 | reasonable ways as different from the original version; or
375 |
376 | d) Limiting the use for publicity purposes of names of licensors or
377 | authors of the material; or
378 |
379 | e) Declining to grant rights under trademark law for use of some
380 | trade names, trademarks, or service marks; or
381 |
382 | f) Requiring indemnification of licensors and authors of that
383 | material by anyone who conveys the material (or modified versions of
384 | it) with contractual assumptions of liability to the recipient, for
385 | any liability that these contractual assumptions directly impose on
386 | those licensors and authors.
387 |
388 | All other non-permissive additional terms are considered "further
389 | restrictions" within the meaning of section 10. If the Program as you
390 | received it, or any part of it, contains a notice stating that it is
391 | governed by this License along with a term that is a further
392 | restriction, you may remove that term. If a license document contains
393 | a further restriction but permits relicensing or conveying under this
394 | License, you may add to a covered work material governed by the terms
395 | of that license document, provided that the further restriction does
396 | not survive such relicensing or conveying.
397 |
398 | If you add terms to a covered work in accord with this section, you
399 | must place, in the relevant source files, a statement of the
400 | additional terms that apply to those files, or a notice indicating
401 | where to find the applicable terms.
402 |
403 | Additional terms, permissive or non-permissive, may be stated in the
404 | form of a separately written license, or stated as exceptions;
405 | the above requirements apply either way.
406 |
407 | 8. Termination.
408 |
409 | You may not propagate or modify a covered work except as expressly
410 | provided under this License. Any attempt otherwise to propagate or
411 | modify it is void, and will automatically terminate your rights under
412 | this License (including any patent licenses granted under the third
413 | paragraph of section 11).
414 |
415 | However, if you cease all violation of this License, then your
416 | license from a particular copyright holder is reinstated (a)
417 | provisionally, unless and until the copyright holder explicitly and
418 | finally terminates your license, and (b) permanently, if the copyright
419 | holder fails to notify you of the violation by some reasonable means
420 | prior to 60 days after the cessation.
421 |
422 | Moreover, your license from a particular copyright holder is
423 | reinstated permanently if the copyright holder notifies you of the
424 | violation by some reasonable means, this is the first time you have
425 | received notice of violation of this License (for any work) from that
426 | copyright holder, and you cure the violation prior to 30 days after
427 | your receipt of the notice.
428 |
429 | Termination of your rights under this section does not terminate the
430 | licenses of parties who have received copies or rights from you under
431 | this License. If your rights have been terminated and not permanently
432 | reinstated, you do not qualify to receive new licenses for the same
433 | material under section 10.
434 |
435 | 9. Acceptance Not Required for Having Copies.
436 |
437 | You are not required to accept this License in order to receive or
438 | run a copy of the Program. Ancillary propagation of a covered work
439 | occurring solely as a consequence of using peer-to-peer transmission
440 | to receive a copy likewise does not require acceptance. However,
441 | nothing other than this License grants you permission to propagate or
442 | modify any covered work. These actions infringe copyright if you do
443 | not accept this License. Therefore, by modifying or propagating a
444 | covered work, you indicate your acceptance of this License to do so.
445 |
446 | 10. Automatic Licensing of Downstream Recipients.
447 |
448 | Each time you convey a covered work, the recipient automatically
449 | receives a license from the original licensors, to run, modify and
450 | propagate that work, subject to this License. You are not responsible
451 | for enforcing compliance by third parties with this License.
452 |
453 | An "entity transaction" is a transaction transferring control of an
454 | organization, or substantially all assets of one, or subdividing an
455 | organization, or merging organizations. If propagation of a covered
456 | work results from an entity transaction, each party to that
457 | transaction who receives a copy of the work also receives whatever
458 | licenses to the work the party's predecessor in interest had or could
459 | give under the previous paragraph, plus a right to possession of the
460 | Corresponding Source of the work from the predecessor in interest, if
461 | the predecessor has it or can get it with reasonable efforts.
462 |
463 | You may not impose any further restrictions on the exercise of the
464 | rights granted or affirmed under this License. For example, you may
465 | not impose a license fee, royalty, or other charge for exercise of
466 | rights granted under this License, and you may not initiate litigation
467 | (including a cross-claim or counterclaim in a lawsuit) alleging that
468 | any patent claim is infringed by making, using, selling, offering for
469 | sale, or importing the Program or any portion of it.
470 |
471 | 11. Patents.
472 |
473 | A "contributor" is a copyright holder who authorizes use under this
474 | License of the Program or a work on which the Program is based. The
475 | work thus licensed is called the contributor's "contributor version".
476 |
477 | A contributor's "essential patent claims" are all patent claims
478 | owned or controlled by the contributor, whether already acquired or
479 | hereafter acquired, that would be infringed by some manner, permitted
480 | by this License, of making, using, or selling its contributor version,
481 | but do not include claims that would be infringed only as a
482 | consequence of further modification of the contributor version. For
483 | purposes of this definition, "control" includes the right to grant
484 | patent sublicenses in a manner consistent with the requirements of
485 | this License.
486 |
487 | Each contributor grants you a non-exclusive, worldwide, royalty-free
488 | patent license under the contributor's essential patent claims, to
489 | make, use, sell, offer for sale, import and otherwise run, modify and
490 | propagate the contents of its contributor version.
491 |
492 | In the following three paragraphs, a "patent license" is any express
493 | agreement or commitment, however denominated, not to enforce a patent
494 | (such as an express permission to practice a patent or covenant not to
495 | sue for patent infringement). To "grant" such a patent license to a
496 | party means to make such an agreement or commitment not to enforce a
497 | patent against the party.
498 |
499 | If you convey a covered work, knowingly relying on a patent license,
500 | and the Corresponding Source of the work is not available for anyone
501 | to copy, free of charge and under the terms of this License, through a
502 | publicly available network server or other readily accessible means,
503 | then you must either (1) cause the Corresponding Source to be so
504 | available, or (2) arrange to deprive yourself of the benefit of the
505 | patent license for this particular work, or (3) arrange, in a manner
506 | consistent with the requirements of this License, to extend the patent
507 | license to downstream recipients. "Knowingly relying" means you have
508 | actual knowledge that, but for the patent license, your conveying the
509 | covered work in a country, or your recipient's use of the covered work
510 | in a country, would infringe one or more identifiable patents in that
511 | country that you have reason to believe are valid.
512 |
513 | If, pursuant to or in connection with a single transaction or
514 | arrangement, you convey, or propagate by procuring conveyance of, a
515 | covered work, and grant a patent license to some of the parties
516 | receiving the covered work authorizing them to use, propagate, modify
517 | or convey a specific copy of the covered work, then the patent license
518 | you grant is automatically extended to all recipients of the covered
519 | work and works based on it.
520 |
521 | A patent license is "discriminatory" if it does not include within
522 | the scope of its coverage, prohibits the exercise of, or is
523 | conditioned on the non-exercise of one or more of the rights that are
524 | specifically granted under this License. You may not convey a covered
525 | work if you are a party to an arrangement with a third party that is
526 | in the business of distributing software, under which you make payment
527 | to the third party based on the extent of your activity of conveying
528 | the work, and under which the third party grants, to any of the
529 | parties who would receive the covered work from you, a discriminatory
530 | patent license (a) in connection with copies of the covered work
531 | conveyed by you (or copies made from those copies), or (b) primarily
532 | for and in connection with specific products or compilations that
533 | contain the covered work, unless you entered into that arrangement,
534 | or that patent license was granted, prior to 28 March 2007.
535 |
536 | Nothing in this License shall be construed as excluding or limiting
537 | any implied license or other defenses to infringement that may
538 | otherwise be available to you under applicable patent law.
539 |
540 | 12. No Surrender of Others' Freedom.
541 |
542 | If conditions are imposed on you (whether by court order, agreement or
543 | otherwise) that contradict the conditions of this License, they do not
544 | excuse you from the conditions of this License. If you cannot convey a
545 | covered work so as to satisfy simultaneously your obligations under this
546 | License and any other pertinent obligations, then as a consequence you may
547 | not convey it at all. For example, if you agree to terms that obligate you
548 | to collect a royalty for further conveying from those to whom you convey
549 | the Program, the only way you could satisfy both those terms and this
550 | License would be to refrain entirely from conveying the Program.
551 |
552 | 13. Use with the GNU Affero General Public License.
553 |
554 | Notwithstanding any other provision of this License, you have
555 | permission to link or combine any covered work with a work licensed
556 | under version 3 of the GNU Affero General Public License into a single
557 | combined work, and to convey the resulting work. The terms of this
558 | License will continue to apply to the part which is the covered work,
559 | but the special requirements of the GNU Affero General Public License,
560 | section 13, concerning interaction through a network will apply to the
561 | combination as such.
562 |
563 | 14. Revised Versions of this License.
564 |
565 | The Free Software Foundation may publish revised and/or new versions of
566 | the GNU General Public License from time to time. Such new versions will
567 | be similar in spirit to the present version, but may differ in detail to
568 | address new problems or concerns.
569 |
570 | Each version is given a distinguishing version number. If the
571 | Program specifies that a certain numbered version of the GNU General
572 | Public License "or any later version" applies to it, you have the
573 | option of following the terms and conditions either of that numbered
574 | version or of any later version published by the Free Software
575 | Foundation. If the Program does not specify a version number of the
576 | GNU General Public License, you may choose any version ever published
577 | by the Free Software Foundation.
578 |
579 | If the Program specifies that a proxy can decide which future
580 | versions of the GNU General Public License can be used, that proxy's
581 | public statement of acceptance of a version permanently authorizes you
582 | to choose that version for the Program.
583 |
584 | Later license versions may give you additional or different
585 | permissions. However, no additional obligations are imposed on any
586 | author or copyright holder as a result of your choosing to follow a
587 | later version.
588 |
589 | 15. Disclaimer of Warranty.
590 |
591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
599 |
600 | 16. Limitation of Liability.
601 |
602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
610 | SUCH DAMAGES.
611 |
612 | 17. Interpretation of Sections 15 and 16.
613 |
614 | If the disclaimer of warranty and limitation of liability provided
615 | above cannot be given local legal effect according to their terms,
616 | reviewing courts shall apply local law that most closely approximates
617 | an absolute waiver of all civil liability in connection with the
618 | Program, unless a warranty or assumption of liability accompanies a
619 | copy of the Program in return for a fee.
620 |
621 | END OF TERMS AND CONDITIONS
622 |
623 | How to Apply These Terms to Your New Programs
624 |
625 | If you develop a new program, and you want it to be of the greatest
626 | possible use to the public, the best way to achieve this is to make it
627 | free software which everyone can redistribute and change under these terms.
628 |
629 | To do so, attach the following notices to the program. It is safest
630 | to attach them to the start of each source file to most effectively
631 | state the exclusion of warranty; and each file should have at least
632 | the "copyright" line and a pointer to where the full notice is found.
633 |
634 |
635 | Copyright (C)
636 |
637 | This program is free software: you can redistribute it and/or modify
638 | it under the terms of the GNU General Public License as published by
639 | the Free Software Foundation, either version 3 of the License, or
640 | (at your option) any later version.
641 |
642 | This program is distributed in the hope that it will be useful,
643 | but WITHOUT ANY WARRANTY; without even the implied warranty of
644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
645 | GNU General Public License for more details.
646 |
647 | You should have received a copy of the GNU General Public License
648 | along with this program. If not, see .
649 |
650 | Also add information on how to contact you by electronic and paper mail.
651 |
652 | If the program does terminal interaction, make it output a short
653 | notice like this when it starts in an interactive mode:
654 |
655 | Copyright (C)
656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
657 | This is free software, and you are welcome to redistribute it
658 | under certain conditions; type `show c' for details.
659 |
660 | The hypothetical commands `show w' and `show c' should show the appropriate
661 | parts of the General Public License. Of course, your program's commands
662 | might be different; for a GUI interface, you would use an "about box".
663 |
664 | You should also get your employer (if you work as a programmer) or school,
665 | if any, to sign a "copyright disclaimer" for the program, if necessary.
666 | For more information on this, and how to apply and follow the GNU GPL, see
667 | .
668 |
669 | The GNU General Public License does not permit incorporating your program
670 | into proprietary programs. If your program is a subroutine library, you
671 | may consider it more useful to permit linking proprietary applications with
672 | the library. If this is what you want to do, use the GNU Lesser General
673 | Public License instead of this License. But first, please read
674 | .
675 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # About
2 |
3 | `bfs` (Browse File System) implements for `emacs` a dynamic tree view
4 | of the file system à la [ranger](https://github.com/ranger/ranger).
5 |
6 | 
7 |
8 | # Install
9 |
10 | Put [bfs.el](./bfs.el) in your load path and add this to your init
11 | file:
12 |
13 | ```elisp
14 | (require 'bfs)
15 | ```
16 |
17 | # Usage
18 |
19 | ## Basic
20 |
21 | To start `bfs` "environment" in the selected frame, run:
22 |
23 | ```elisp
24 | M-x bfs
25 | ```
26 |
27 | Then in the child window (the center window), you can press the keys
28 | `p`, `n`, `M-p`, `M-n`, `b` and `f` to select the files to be
29 | previewed.
30 |
31 | You can scroll the preview window (the right window) from the child
32 | window by pressing the keys `` and ``.
33 |
34 | You can quit `bfs` either by:
35 | 1. pressing the key `q` or,
36 | 2. calling any command that invalidates `bfs` "environment" (see
37 | `bfs-check-environment`).
38 |
39 | For instance, your `bfs` "environment" stops to be valid:
40 | - when you switch to a buffer not attached to a file,
41 | - when you modify the layout deleting or rotating windows,
42 | - when you run any command that makes the previewed buffer
43 | no longer match the child entry (filename in the child window).
44 |
45 | **Note 1:** If you call bfs with universal argument, `bfs` starts
46 | by previewing the "file" (see `bfs-child-default`) of the
47 | `current-buffer` in the preview window. If you call `bfs` without
48 | universal argument, `bfs` starts with the last file you've visited in
49 | the `bfs` "environment".
50 |
51 | **Note 2:** You can only have one `bfs` "environment" running at a
52 | time.
53 |
54 | **Note 3:** All the commands (except `bfs`) are provided via the
55 | `bfs-mode-map` that is the local map used in the child window (the
56 | center window).
57 |
58 | **Note 4:** You can use `isearch` commands to select files in the
59 | child window, the preview window will be updated automatically.
60 |
61 | ## Finding files
62 |
63 | `bfs` provides two commands `bfs-find-file` and
64 | `bfs-project-find-file` respectively bound to `C-f` and `M-f` to find
65 | files. Those commands automatically update `bfs` "environment" once
66 | you've selected the file.
67 |
68 | If what you want is to find a file and leave `bfs` "environment", just
69 | use the emacs built-in commands `find-file` and `project-find-file`.
70 |
71 | ## Marking files
72 |
73 | `bfs` comes with its mark system that allows you to mark child
74 | entries and kill marked entries (not the files). The commands
75 | provided are bound in `bfs-mode-map` as follow:
76 |
77 | | key | command |
78 | | --- | ------------------ |
79 | | `m` | `bfs-mark` |
80 | | `u` | `bfs-unmark` |
81 | | `U` | `bfs-unmark-all` |
82 | | `t` | `bfs-toggle-marks` |
83 | | `k` | `bfs-kill-marked` |
84 | | `%` | `bfs-mark-regexp` |
85 |
86 | ## Filetering
87 |
88 | You can filter the files listed in the child window with the following
89 | commands:
90 | 1. `bfs-hide-dotfiles` (bound to `.`) toggles the visibility of
91 | dotfiles,
92 | 2) `bfs-narrow` (bound to `/`) dynamically filters (narrows) `bfs`
93 | child buffer to filenames matching a regexp read from minibuffer.
94 |
95 | # Options
96 |
97 | I'll document this section later.
98 |
99 | But until it is done you can find most of the user options in the
100 | section `User options` of [bfs.el](./bfs.el) file.
101 |
102 | # Features from `ranger`
103 |
104 | I've never used `ranger` so I won't miss nothing from it. Another
105 | consequence is that I'm not trying to implement the features it
106 | offers. But, I really like its layout. I think it offers so far the
107 | best way to *discover code bases* and to *browse file systems*.
108 |
109 | From the beginning, the unique goal of `bfs` has been to give to emacs
110 | users a way to dynamically visualize the structure of their file
111 | system with file preview. **Nothing more**
112 |
113 | # `bfs` is not a file manager
114 |
115 | `bfs` is not a file manager. It doesn't provide any commands to
116 | copy, paste, rename, modify ownership, compress files... Those
117 | features are already implemented in others tools like `dired` and
118 | `wdired`. And if you need to do more elaborated tasks on your files
119 | you still can use your favorite `shell`.
120 |
121 | `bfs` doesn't try to replace or re-implement features from those
122 | tools.
123 |
124 | However, `bfs` is implemented in such a way that it is possible to
125 | implement these features on top of each other in separate packages.
126 |
--------------------------------------------------------------------------------
/bfs.el:
--------------------------------------------------------------------------------
1 | ;;; bfs.el --- Browse File System -*- lexical-binding: t; -*-
2 |
3 | ;; Copyright (C) 2021 Tony Aldon
4 |
5 | ;; Author: Tony Aldon
6 | ;; Version: 0.21.0
7 | ;; Package-Requires: ((emacs "27.1") (dash "2.17.0") (f "0.20.0") (s "1.12.0"))
8 | ;; Keywords: files
9 | ;; Homepage: https://github.com/tonyaldon/bfs
10 |
11 | ;; This file is not part of GNU Emacs.
12 |
13 | ;; This program is free software: you can redistribute it and/or modify
14 | ;; it under the terms of the GNU General Public License as published by
15 | ;; the Free Software Foundation, either version 3 of the License, or
16 | ;; (at your option) any later version.
17 |
18 | ;; This program is distributed in the hope that it will be useful,
19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 | ;; GNU General Public License for more details.
22 |
23 | ;; You should have received a copy of the GNU General Public License
24 | ;; along with this program. If not, see .
25 |
26 | ;;; Commentary:
27 |
28 | ;; TODO:
29 |
30 | ;;; Code:
31 |
32 | (require 'dash)
33 | (require 'dired)
34 | (require 'f)
35 | (require 'ls-lisp)
36 | (require 's)
37 | (require 'text-property-search)
38 | (require 'cl-macs)
39 |
40 | ;;; User options
41 |
42 | (defgroup bfs nil "Browsing File System." :group 'files)
43 |
44 | (defface bfs-directory
45 | '((t (:inherit dired-directory)))
46 | "Face used for subdirectories."
47 | :group 'bfs)
48 |
49 | (defface bfs-top-parent-directory
50 | '((t (:inherit dired-header)))
51 | "Face used for parent directory path in `bfs-top-buffer-name' buffer."
52 | :group 'bfs)
53 |
54 | (defface bfs-top-child-entry
55 | '((t (:inherit default :weight ultra-bold)))
56 | "Face used for child entry in `bfs-top-buffer-name' buffer."
57 | :group 'bfs)
58 |
59 | (defface bfs-top-symlink-name
60 | '((t (:inherit dired-symlink)))
61 | "Face of symlink name in `bfs-top-buffer-name'."
62 | :group 'bfs)
63 |
64 | (defface bfs-top-symlink-arrow
65 | '((t (:inherit dired-symlink)))
66 | "Face of the arrow link used for symlinks in `bfs-top-buffer-name'."
67 | :group 'bfs)
68 |
69 | (defface bfs-top-symlink-directory-target
70 | '((t (:inherit bfs-directory)))
71 | "Face of symlink target when it is a directory in `bfs-top-buffer-name'."
72 | :group 'bfs)
73 |
74 | (defface bfs-top-symlink-file-target
75 | '((t (:inherit default)))
76 | "Face of symlink target when it is a file in `bfs-top-buffer-name'."
77 | :group 'bfs)
78 |
79 | (defface bfs-top-broken-symlink
80 | (if (>= emacs-major-version 28)
81 | '((t (:inherit dired-broken-symlink)))
82 | '((t (:inherit error))))
83 | "Face of broken links used in `bfs-top-buffer-name'."
84 | :group 'bfs)
85 |
86 | (defvar bfs-top-mode-line-background
87 | (face-background 'mode-line-inactive nil t)
88 | "Background color of `bfs-top-buffer-name' mode line.
89 | You can change the value with any hexa color. For instance, if you
90 | want the background to be white, set `bfs-top-mode-line-background'
91 | to \"#ffffff\".")
92 |
93 | (defvar bfs-top-mode-line-foreground
94 | (face-foreground 'mode-line-inactive nil t)
95 | "Foreground color of `bfs-top-buffer-name' mode line.
96 | You can change the value with any hexa color. For instance, if you
97 | want the foreground to be black, set `bfs-top-mode-line-background'
98 | to \"#000000\".")
99 |
100 | (defvar bfs-top-mode-line-format
101 | `((:eval (format "%s" (bfs-top-mode-line))))
102 | "The mode line format used in `bfs-top-buffer-name'.
103 | See `bfs-top-mode-line'.
104 |
105 | And see `mode-line-format' if you want to customize
106 | `bfs-top-mode-line-format'.")
107 |
108 | (defvar bfs-top-line-function 'bfs-top-line-ellipsed
109 | "Function that return the formated text used in `bfs-top-buffer-name'.
110 | This function takes one argument CHILD (a file path corresponding
111 | to the current child entry) and return the formatted string obtained
112 | from CHILD.
113 |
114 | See `bfs-top-line-ellipsed', `bfs-top-line-default', `bfs-child'.")
115 |
116 | (defvar bfs-kill-buffer-eagerly nil
117 | "When t, kill opened buffer upon a new child entry file is previewed.
118 | When nil, opened buffers are killed when leaving `bfs' environment.")
119 |
120 | (defvar bfs-ignored-extensions '("mkv" "iso" "mp4" "jpg" "png")
121 | "Don't preview files with those extensions.")
122 |
123 | (defvar bfs-max-size large-file-warning-threshold
124 | "Don't preview files larger than this size.")
125 |
126 | (defvar bfs-ls-parent-function 'bfs-ls
127 | "Function of one argument DIR (a file path) that
128 | return a list of filename (not file path) contained in DIR.
129 | \".\" or \"..\" must always be omitted.
130 | This is the function we use to fill `bfs-parent-buffer-name'.
131 | See `bfs-ls'.")
132 |
133 | (defvar bfs-ls-child-function 'bfs-ls
134 | "Function of one argument DIR (a file path) that
135 | return a list of filename (not file path) contained in DIR.
136 | \".\" or \"..\" must always be omitted.
137 | This is the function we use to fill `bfs-child-buffer-name'.
138 | See `bfs-ls'.")
139 |
140 | (defvar bfs-dired-hide-details t
141 | "When t, details are hidden in dired buffers in the preview window.
142 | When nil, dired buffers are visited only with your settings
143 | for `dired-mode'. So, if you hide the details, they will be
144 | hidden too, if you don't they won't be hidden.
145 |
146 | See `dired-hide-details-mode' and the function `bfs-dired-hide-details'.")
147 |
148 | ;;; Visited files
149 |
150 | (defvar bfs-visited-last nil
151 | "List of last child files visited for a given parent directory.
152 | Child files are uniquely added to `bfs-visited-last' by the
153 | command `bfs-backward' command.
154 |
155 | This allow `bfs-forward' to be smart.")
156 |
157 | (defun bfs-visited-last-in-dir (dir)
158 | "Return the last file visited in DIR directory.
159 |
160 | Return nil if any file has been visited in DIR so far.
161 | See `bfs-visited-last'."
162 | (--first (string= dir (f-dirname it)) bfs-visited-last))
163 |
164 | (defun bfs-visited-last-push (child)
165 | "Add CHILD to `bfs-visited-last' list conditionally."
166 | (unless (or (null child)
167 | (and (file-directory-p child)
168 | (not (file-accessible-directory-p child)))
169 | (not (bfs-valid-child-p child)))
170 | (cl-flet ((dirname= (x y) (string= (f-dirname x) (f-dirname y))))
171 | (setq bfs-visited-last
172 | (cons child (--remove (dirname= child it) bfs-visited-last))))))
173 |
174 | (defvar bfs-visited nil
175 | "List of all the visited childs.")
176 |
177 | (defvar bfs-visited-history nil
178 | "Minibuffer history of the command `bfs-visit'.")
179 |
180 | (defun bfs-visit ()
181 | "Visit a file (with completion) that has already been visited in bfs.
182 | See `bfs-visited'."
183 | (interactive)
184 | (bfs-visited-last-push (bfs-child))
185 | (let ((file (completing-read "Visit file: " bfs-visited
186 | nil t nil 'bfs-visited-history)))
187 | (if-let (((file-directory-p file))
188 | (child-in-dir (or (bfs-visited-last-in-dir file)
189 | (bfs-first-valid-child file))))
190 | (bfs-update child-in-dir)
191 | (bfs-update file))))
192 |
193 | ;;; Movements
194 |
195 | (defun bfs-previous ()
196 | "Preview previous file."
197 | (interactive)
198 | (unless (bobp) (forward-line -1))
199 | (bfs-preview (bfs-child)))
200 |
201 | (defun bfs-next ()
202 | "Preview next file."
203 | (interactive)
204 | (unless (= (line-number-at-pos) (1- (line-number-at-pos (point-max))))
205 | (forward-line))
206 | (bfs-preview (bfs-child)))
207 |
208 | (defun bfs-backward ()
209 | "Update `bfs' environment making parent entry the child entry.
210 | In other words, go up by one node in the file system tree."
211 | (interactive)
212 | (bfs-visited-last-push (bfs-child))
213 | (bfs-update default-directory))
214 |
215 | (defun bfs-forward ()
216 | "Update `bfs' environment making `bfs-child' the parent.
217 | In other words, go down by one node in the file system tree.
218 |
219 | If `bfs-child' is a readable file, leave `bfs' and visit that file.
220 | If `bfs-child' is an empty directory, leave `bfs' and visit that file."
221 | (interactive)
222 | (if-let ((child (bfs-child)))
223 | (cond ((and (file-directory-p child)
224 | (not (file-accessible-directory-p child)))
225 | (message "Permission denied: %s" child))
226 | ((file-directory-p child)
227 | (let* ((visited (bfs-visited-last-in-dir child))
228 | (ls-child-filtered (bfs-ls-child-filtered child))
229 | (visited-belong-child-filtered-p
230 | (and visited
231 | (member visited (--map (f-join child it)
232 | ls-child-filtered)))))
233 | (cond
234 | (visited-belong-child-filtered-p
235 | (bfs-update visited))
236 | (ls-child-filtered
237 | (bfs-update (f-join child (car ls-child-filtered))))
238 | ((and (null ls-child-filtered)
239 | (funcall bfs-ls-child-function child))
240 | (message "Can't go forward, filters are in effect: %s"
241 | bfs-ls-child-filter-functions))
242 | (t (message "Can't go forward, directory is empty")))))
243 | ((bfs-broken-symlink-p child)
244 | (message "Symlink is broken: %s" child))
245 | ((f-file-p child)
246 | (let (child-buffer)
247 | (condition-case err
248 | (setq child-buffer (find-file-noselect (file-truename child)))
249 | (file-error (message "%s" (error-message-string err))))
250 | (when child-buffer
251 | (bfs-clean)
252 | (delete-other-windows)
253 | (find-file (file-truename child))))))))
254 |
255 | (defun bfs-parent-goto-previous-dir ()
256 | "Go to the previous dir in parent buffer.
257 |
258 | Return file path of the previous dir in parent buffer.
259 | Return nil if the current parent entry is the first dir
260 | in the parent buffer.
261 |
262 | See: `bfs-parent-sibling-dir'."
263 | (with-current-buffer bfs-parent-buffer-name
264 | (unless (bobp)
265 | (forward-line -1)
266 | (let ((file (get-text-property (point) 'bfs-file)))
267 | (while (and (not (bobp)) file (not (file-directory-p file)))
268 | (forward-line -1)
269 | (setq file (get-text-property (point-at-bol) 'bfs-file)))
270 | (when (and file (file-directory-p file)) file)))))
271 |
272 | (defun bfs-parent-goto-next-dir ()
273 | "Go to the next dir in parent buffer.
274 |
275 | Return file path of the next dir in parent buffer.
276 | Return nil if the current parent entry is the last dir
277 | in the parent buffer.
278 |
279 | See: `bfs-parent-sibling-dir'."
280 | (with-current-buffer bfs-parent-buffer-name
281 | (when-let ((match (text-property-search-forward 'bfs-file nil nil 'not-current))
282 | (file (prop-match-value match)))
283 | (while (and file (not (file-directory-p file)))
284 | (setq match (text-property-search-forward 'bfs-file nil nil 'not-current))
285 | (setq file (and match (prop-match-value match))))
286 | file)))
287 |
288 | (defun bfs-parent-sibling-dir (sibling)
289 | "Make SIBLING of current parent entry the parent of the `bfs' environment.
290 | SIBLING can be 'previous or 'next.
291 | See: `bfs-parent-previous' and `bfs-next-previous'."
292 | (bfs-visited-last-push (bfs-child))
293 | (when-let ((dir (funcall (pcase sibling
294 | ('previous 'bfs-parent-goto-previous-dir)
295 | ('next 'bfs-parent-goto-next-dir)))))
296 | (if-let ((child-in-dir (or (bfs-visited-last-in-dir dir)
297 | (bfs-first-valid-child dir))))
298 | (bfs-update child-in-dir)
299 | (with-current-buffer bfs-parent-buffer-name
300 | (bfs-line-highlight-parent))
301 | (with-current-buffer bfs-child-buffer-name
302 | (let ((inhibit-read-only t))
303 | (erase-buffer)
304 | (setq default-directory dir)
305 | (insert "No preview")))
306 | (bfs-preview nil)
307 | (bfs-top-update))))
308 |
309 | (defun bfs-parent-previous ()
310 | "Make previous parent entry the parent of the `bfs' environment."
311 | (interactive)
312 | (bfs-parent-sibling-dir 'previous))
313 |
314 | (defun bfs-parent-next ()
315 | "Make next parent entry the parent of the `bfs' environment."
316 | (interactive)
317 | (bfs-parent-sibling-dir 'next))
318 |
319 | ;;; Scrolling
320 |
321 | (defun bfs-half-window-height ()
322 | "Compute half window height."
323 | (/ (window-body-height) 2))
324 |
325 | (defun bfs-scroll-preview-down-half-window ()
326 | "Scroll preview window down of half window height."
327 | (interactive)
328 | (scroll-other-window-down (bfs-half-window-height)))
329 |
330 | (defun bfs-scroll-preview-up-half-window ()
331 | "Scroll preview window up of half window height."
332 | (interactive)
333 | (scroll-other-window (bfs-half-window-height)))
334 |
335 | (defun bfs-scroll-down-half-window ()
336 | "Scroll child window down of half window height."
337 | (interactive)
338 | (scroll-down (bfs-half-window-height))
339 | (bfs-preview (bfs-child)))
340 |
341 | (defun bfs-scroll-up-half-window ()
342 | "Scroll child window up of half window height."
343 | (interactive)
344 | (scroll-up (bfs-half-window-height))
345 | (if (eobp) (bfs-previous)
346 | (bfs-preview (bfs-child))))
347 |
348 | (defun bfs-beginning-of-buffer ()
349 | "Move to beginning of buffer."
350 | (interactive)
351 | (call-interactively 'beginning-of-buffer)
352 | (bfs-preview (bfs-child)))
353 |
354 | (defun bfs-end-of-buffer ()
355 | "Move to beginning of buffer."
356 | (interactive)
357 | (call-interactively 'end-of-buffer)
358 | (if (eobp) (bfs-previous)
359 | (bfs-preview (bfs-child))))
360 |
361 | ;;; Find files and dired commands
362 |
363 | (defun bfs-dired ()
364 | "Quit bfs and open a dired buffer listing the files that was in child buffer."
365 | (interactive)
366 | (let ((dir default-directory)
367 | (file (bfs-child)))
368 | (delete-other-windows)
369 | (bfs-clean)
370 | (dired dir)
371 | (when file
372 | (dired-goto-file file))))
373 |
374 | (defun bfs-toggle-dired-details ()
375 | "Toggle visibility of details in preview window if showing a Dired buffer.
376 | See `dired-hide-details-mode'."
377 | (interactive)
378 | (with-selected-window (plist-get bfs-windows :preview)
379 | (when (equal major-mode 'dired-mode)
380 | (dired-hide-details-mode 'toggle))))
381 |
382 | (defun bfs-find-file (file)
383 | "Find a FILE with your completion framework and update `bfs' environment."
384 | (interactive
385 | (list (read-file-name "Find file:" nil default-directory t)))
386 | (bfs-visited-last-push (bfs-child))
387 | (if-let (((file-directory-p file))
388 | (child-in-dir (or (bfs-visited-last-in-dir file)
389 | (bfs-first-valid-child file))))
390 | (bfs-update child-in-dir)
391 | (bfs-update file)))
392 |
393 | (defun bfs-project-find-file-in (filename dirs project)
394 | "Complete FILENAME in DIRS in PROJECT and update `bfs' environment."
395 | (let* ((all-files (project-files project dirs))
396 | (completion-ignore-case read-file-name-completion-ignore-case)
397 | (file (funcall project-read-file-name-function
398 | "Find file" all-files nil nil
399 | filename)))
400 | (if (string= file "")
401 | (user-error "You didn't specify the file")
402 | (if-let (((file-directory-p file))
403 | (child-in-dir (or (bfs-visited-last-in-dir file)
404 | (bfs-first-valid-child file))))
405 | (bfs-update child-in-dir)
406 | (bfs-update file)))))
407 |
408 | (defun bfs-project-find-file ()
409 | "Update `bfs' env visiting a file (with completion) in the current project.
410 |
411 | The completion default is the filename at point, determined by
412 | `thing-at-point' (whether such file exists or not)."
413 | (interactive)
414 | (bfs-visited-last-push (bfs-child))
415 | (let* ((pr (project-current t))
416 | (dirs (list (project-root pr))))
417 | (bfs-project-find-file-in (thing-at-point 'filename) dirs pr)))
418 |
419 | ;;; bfs modes
420 |
421 | ;;;; Font Lock mode
422 |
423 | (defvar bfs-top-font-lock-keywords nil
424 | "Additional expressions to highlight in `bfs-top-mode',
425 | using `font-lock-mode'.")
426 |
427 | (defvar bfs-preview-font-lock-keywords nil
428 | "Additional expressions to highlight in `bfs-preview-mode',
429 | using `font-lock-mode'.")
430 |
431 | (defvar bfs-parent-font-lock-keywords
432 | '((bfs-font-lock-match-dir-entry+info 0 'bfs-directory))
433 | "Additional expressions to highlight in `bfs-parent-mode',
434 | using `font-lock-mode'.")
435 |
436 | (defvar bfs-font-lock-keywords
437 | '((bfs-font-lock-match-dir-entry+info 0 'bfs-directory))
438 | "Additional expressions to highlight in `bfs-mode',
439 | using `font-lock-mode'.")
440 |
441 | (defun bfs-font-lock-match-dir-entry (_bound)
442 | "Matcher that matches an entry that is a directory.
443 | BOUND is the limit of the search. (In general, BOUND has the
444 | value `point-max'. See `font-lock.el' file).
445 | This function set the match data.
446 | Return nil if no directory entry found."
447 | (when-let ((match (text-property-search-forward 'bfs-entry))
448 | (file (get-text-property (point-at-bol) 'bfs-file)))
449 | (when (file-directory-p file)
450 | (let ((match-beg (prop-match-beginning match))
451 | (match-end (prop-match-end match)))
452 | (set-match-data `(,match-beg ,match-end))
453 | match-end))))
454 |
455 | (defun bfs-font-lock-match-dir-entry+info (_bound)
456 | "Matcher that matches an entry that is a directory.
457 | BOUND is the limit of the search. (In general, BOUND has the
458 | value `point-max'. See `font-lock.el' file).
459 | This function set the match data.
460 | Return nil if no directory entry found."
461 | (when-let ((match (text-property-search-forward 'bfs-entry))
462 | (file (get-text-property (point-at-bol) 'bfs-file)))
463 | (when (file-directory-p file)
464 | (let ((match-beg (prop-match-beginning match))
465 | (match-end (point-at-eol)))
466 | (set-match-data `(,match-beg ,match-end))
467 | match-end))))
468 |
469 | ;;;; Keymaps
470 |
471 | (defvar bfs-mode-map
472 | (let ((map (make-sparse-keymap)))
473 |
474 | (define-key map (kbd "p") 'bfs-previous)
475 | (define-key map (kbd "n") 'bfs-next)
476 | (define-key map (kbd "b") 'bfs-backward)
477 | (define-key map (kbd "f") 'bfs-forward)
478 | (define-key map (kbd "RET") 'bfs-forward)
479 | (define-key map (kbd "M-p") 'bfs-parent-previous)
480 | (define-key map (kbd "M-n") 'bfs-parent-next)
481 |
482 | (define-key map (kbd "") 'bfs-scroll-preview-down-half-window)
483 | (define-key map (kbd "") 'bfs-scroll-preview-up-half-window)
484 | (define-key map (kbd "C-") 'bfs-scroll-down-half-window)
485 | (define-key map (kbd "C-") 'bfs-scroll-up-half-window)
486 | (define-key map (kbd "<") 'bfs-beginning-of-buffer)
487 | (define-key map (kbd ">") 'bfs-end-of-buffer)
488 | (define-key map (kbd "TAB") 'bfs-toggle-dired-details)
489 |
490 | (define-key map (kbd "v") 'bfs-visit)
491 | (define-key map (kbd "C-f") 'bfs-find-file)
492 | (define-key map (kbd "M-f") 'bfs-project-find-file)
493 |
494 | (define-key map (kbd "'") 'bfs-dired)
495 |
496 | (define-key map (kbd "m") 'bfs-mark)
497 | (define-key map (kbd "u") 'bfs-unmark)
498 | (define-key map (kbd "U") 'bfs-unmark-all)
499 | (define-key map (kbd "t") 'bfs-toggle-marks)
500 | (define-key map (kbd "k") 'bfs-kill-marked)
501 | (define-key map (kbd "%") 'bfs-mark-regexp)
502 |
503 | (define-key map (kbd ".") 'bfs-hide-dotfiles)
504 | (define-key map (kbd "/") 'bfs-narrow)
505 |
506 | (define-key map (kbd "g") 'revert-buffer)
507 | (define-key map (kbd "q") 'bfs-quit)
508 | map)
509 | "Keymap for `bfs-mode' used in `bfs-child-buffer-name' buffer.")
510 |
511 | (defvar bfs-parent-mode-map
512 | (let ((map (make-sparse-keymap)))
513 | (define-key map (kbd "q") 'bfs-quit)
514 | map)
515 | "Keymap for `bfs-parent-mode' used in `bfs-parent-buffer-name' buffer.")
516 |
517 | ;;;; Highlight line in child and parent buffers
518 |
519 | (defvar-local bfs-line-overlay nil
520 | "Overlay used to highlight the current line in `bfs-mode'.
521 | Also used in `bfs-parent-mode'.")
522 |
523 | (defun bfs-line-move-overlay (overlay)
524 | "Move `bfs-line-overlay' to the line including the point by OVERLAY."
525 | (move-overlay
526 | overlay (line-beginning-position) (line-beginning-position 2)))
527 |
528 | (defun bfs-line-highlight-child ()
529 | "Highlight current child entry in child buffer.
530 | The highlighting is peformed with an overlay.
531 |
532 | This function must be called with `bfs-child-buffer-name' buffer current.
533 | Here an example:
534 | (with-current-buffer bfs-child-buffer-name
535 | (bfs-line-highlight-child))"
536 | (unless bfs-line-overlay
537 | (setq bfs-line-overlay (make-overlay (point) (point))))
538 | (let* ((entry-point
539 | (or (and (get-text-property (point-at-bol) 'bfs-entry) (point-at-bol))
540 | (next-single-property-change (point-at-bol) 'bfs-entry nil (point-at-eol))))
541 | (face-entry (and entry-point
542 | (if (listp (get-text-property entry-point 'face))
543 | (car (get-text-property entry-point 'face))
544 | (get-text-property entry-point 'face))))
545 | (foreground-line
546 | (or (and face-entry (face-foreground face-entry nil t))
547 | (face-foreground 'default nil t)))
548 | (background-line
549 | (or (and face-entry (face-background face-entry nil t))
550 | (face-background 'default nil t)))
551 | (face `(:background ,foreground-line
552 | :foreground ,background-line
553 | :weight ultra-bold
554 | :extend t)))
555 | (overlay-put bfs-line-overlay 'face face))
556 | (bfs-line-move-overlay bfs-line-overlay))
557 |
558 | (defun bfs-line-highlight-parent ()
559 | "Highlight current parent entry in parent buffer.
560 | The highlighting is peformed with an overlay.
561 |
562 | This function must be called with `bfs-parent-buffer-name' buffer current.
563 | Here an example:
564 | (with-current-buffer bfs-parent-buffer-name
565 | (bfs-line-highlight-parent))"
566 | (unless bfs-line-overlay
567 | (setq bfs-line-overlay (make-overlay (point) (point))))
568 | (let ((face `(:background ,(face-foreground 'bfs-directory nil t)
569 | :foreground ,(or (face-background 'bfs-directory nil t)
570 | (face-background 'default nil t))
571 | :weight ultra-bold
572 | :extend t)))
573 | (overlay-put bfs-line-overlay 'face face))
574 | (bfs-line-move-overlay bfs-line-overlay))
575 |
576 | ;;;; bfs-top-mode
577 |
578 | (defun bfs-top-mode-line (&optional child)
579 | "Return the string that describe CHILD file.
580 | This string is used in the mode line of `bfs-top-buffer-name' buffer.
581 | If CHILD is nil, default to `bfs-child'."
582 | (if-let ((file (or child (bfs-child))))
583 | (with-temp-buffer
584 | (insert-directory file "-lh")
585 | (delete-char -1) ; delete the last newline character
586 | (goto-char (point-min))
587 | (dired-goto-next-file)
588 | (delete-region (point) (point-at-eol))
589 | (concat " " (buffer-substring-no-properties (point-min) (point-max))))
590 | " No child entry to be previewed"))
591 |
592 | (define-derived-mode bfs-top-mode fundamental-mode "bfs-top"
593 | "Mode use in `bfs-top-buffer-name' buffer.
594 | See `bfs-top-buffer'."
595 | (setq-local cursor-type nil)
596 | (setq-local global-hl-line-mode nil)
597 | (setq mode-line-format bfs-top-mode-line-format)
598 | (face-remap-add-relative 'mode-line-inactive
599 | :background bfs-top-mode-line-background)
600 | (face-remap-add-relative 'mode-line-inactive
601 | :foreground bfs-top-mode-line-foreground)
602 | (face-remap-add-relative 'mode-line
603 | :background bfs-top-mode-line-background)
604 | (face-remap-add-relative 'mode-line
605 | :foreground bfs-top-mode-line-foreground)
606 | (setq buffer-read-only t)
607 | (setq-local font-lock-defaults '(bfs-top-font-lock-keywords t)))
608 |
609 | ;;;; bfs-preview-mode
610 |
611 | (define-derived-mode bfs-preview-mode fundamental-mode "bfs-preview"
612 | "Mode use in `bfs-preview-buffer-name'."
613 | (visual-line-mode t)
614 | (setq buffer-read-only t)
615 | (setq-local font-lock-defaults '(bfs-preview-font-lock-keywords t)))
616 |
617 | ;;;; bfs-parent-mode
618 |
619 | (defvar bfs-parent-mode-line-format nil
620 | "If non-nil, this is the `mode-line-format' of `bfs-parent-mode'.")
621 |
622 | (define-derived-mode bfs-parent-mode fundamental-mode "bfs-parent"
623 | "Mode used in `bfs-parent-buffer-name' buffer.
624 | In `bfs-parent-mode', `default-directory' is set to DIR, and
625 | must be the parent directory of the file listed in
626 | `bfs-parent-buffer-name' buffer.
627 | See `bfs-parent-buffer' command."
628 | (setq-local cursor-type nil)
629 | (setq-local global-hl-line-mode nil)
630 | (add-hook 'post-command-hook #'bfs-line-highlight-parent nil t)
631 | (setq mode-line-format (or bfs-parent-mode-line-format ""))
632 | (setq buffer-read-only t)
633 | (setq-local font-lock-defaults '(bfs-parent-font-lock-keywords t)))
634 |
635 | ;;;; bfs-mode
636 |
637 | (defvar bfs-mode-line-format nil
638 | "If non-nil, this is the `mode-line-format' of `bfs-mode'.")
639 |
640 | (define-derived-mode bfs-mode fundamental-mode "bfs"
641 | "Mode used in `bfs-child-buffer-name' buffer.
642 | In `bfs-mode', `default-directory' is set to PARENT, and
643 | must be the parent directory of the file listed in
644 | `bfs-child-buffer-name' buffer.
645 | See `bfs-child-buffer' command."
646 | (setq-local cursor-type nil)
647 | (setq-local global-hl-line-mode nil)
648 | (add-hook 'post-command-hook #'bfs-line-highlight-child nil t)
649 | (setq mode-line-format (or bfs-mode-line-format ""))
650 | (setq buffer-read-only t)
651 | (setq-local revert-buffer-function #'bfs-revert)
652 | (setq-local font-lock-defaults '(bfs-font-lock-keywords t)))
653 |
654 | ;;; Utilities
655 |
656 | (defun bfs-child ()
657 | "Return file path corresponding to the current child entry.
658 | If `bfs-child-buffer-name' isn't lived return nil."
659 | (when (buffer-live-p (get-buffer bfs-child-buffer-name))
660 | (with-current-buffer bfs-child-buffer-name
661 | (get-text-property (point) 'bfs-file))))
662 |
663 | (defun bfs-goto-entry (entry)
664 | "Move the cursor to the line ENTRY.
665 | If there is no line with ENTRY or ENTRY is nil, go to the first line."
666 | (goto-char (point-min))
667 | (text-property-search-forward 'bfs-entry entry t)
668 | (beginning-of-line))
669 |
670 | (defun bfs-valid-child-p (child)
671 | "Return t if CHILD (file path) can be a child in `bfs' environment."
672 | (cond ((or (string= "" child) (not (f-exists-p child)))
673 | (message "File doesn't exist: %s" child)
674 | nil)
675 | ((f-root-p child)
676 | (message "Root can't be a bfs child: %s" child)
677 | nil)
678 | (t t)))
679 |
680 | (defun bfs-first-valid-child (dir)
681 | "Return the first file of DIR directory satisfaying `bfs-valid-child-p'.
682 |
683 | Return nil if DIR isn't accesible. See `file-accessible-directory-p'.
684 | Return nil if none are found.
685 | Return an empty string if DIR directory is empty."
686 | (when (file-accessible-directory-p dir)
687 | (--first (bfs-valid-child-p it)
688 | (--map (f-join dir it) (bfs-ls-child-filtered dir)))))
689 |
690 | (defun bfs-child-default (buffer)
691 | "Return the file name of BUFFER.
692 | Return `default-directory' if we can't determine a \"suitable\"
693 | file name for BUFFER."
694 | (with-current-buffer buffer
695 | (cond ((buffer-file-name))
696 | ((and (equal major-mode 'dired-mode)
697 | (dired-file-name-at-point)
698 | (not (member (f-filename (dired-file-name-at-point)) '("." ".."))))
699 | (dired-file-name-at-point))
700 | ((bfs-ls-child-filtered default-directory)
701 | (f-join default-directory
702 | (car (bfs-ls-child-filtered default-directory))))
703 | (t default-directory))))
704 |
705 | (defun bfs-broken-symlink-p (file)
706 | "Return t if FILE is a broken symlink.
707 | Return nil if not."
708 | (and (file-symlink-p file) (not (file-exists-p (file-truename file)))))
709 |
710 | (defun bfs-preview-current-buffer-name ()
711 | "Return the `buffer-name' of the preview window if lived.
712 | Return nil if preview window isn't lived.
713 |
714 | See `bfs-windows'."
715 | (when (window-live-p (plist-get bfs-windows :preview))
716 | (buffer-name (window-buffer (plist-get bfs-windows :preview)))))
717 |
718 | (defun bfs-preview-matches-child-p ()
719 | "Return t if buffer in preview window match the child entry."
720 | (when-let*
721 | ((preview-buffer-name (bfs-preview-current-buffer-name))
722 | (preview-file-path
723 | (with-current-buffer preview-buffer-name
724 | (cond ((equal major-mode 'dired-mode) default-directory)
725 | ((string= preview-buffer-name bfs-preview-buffer-name)
726 | bfs-preview-buffer-file-name)
727 | (t (buffer-file-name))))))
728 | (let ((child (bfs-child)))
729 | (cond ((and (null child) (equal preview-file-path 'no-child-entry)) t)
730 | ((and child (equal preview-file-path 'no-child-entry)) nil)
731 | ((and child (bfs-broken-symlink-p child))
732 | (string= preview-file-path (file-truename child)))
733 | (child (f-equal-p preview-file-path child))))))
734 |
735 | (defun bfs-isearch-preview-update ()
736 | "Update the preview window with the current child entry file.
737 |
738 | Intended to be added to `isearch-update-post-hook' and
739 | `isearch-mode-end-hook'. This allows to preview the file the
740 | cursor has moved to using \"isearch\" commands in
741 | `bfs-child-buffer-name' buffer."
742 | (when (string= (buffer-name) bfs-child-buffer-name)
743 | (bfs-preview (bfs-child))))
744 |
745 | (defun bfs-dired-hide-details ()
746 | "Hide details in Dired mode.
747 | This function is meant to be used as the deepest hook
748 | of `dired-mode-hook'."
749 | (dired-hide-details-mode))
750 |
751 | ;;; List directories
752 |
753 | (defvar bfs-ls-child-filter-functions nil
754 | "List of filter functions that are applied to `bfs-ls-child-function' list.
755 |
756 | Each function takes one argument FILENAME (the name, in linux system, part
757 | after the last \"/\") and returns non-nil if we want FILENAME
758 | to be kept in the \"ls\" listing of `bfs-child-buffer-name'.
759 |
760 | See `bfs-insert-ls-child'.")
761 |
762 | (defun bfs-ls-group-directory-first (file-alist)
763 | "Return a list of FILEs sorting FILE-ALIST with directories first.
764 | FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES).
765 | If FILE is one of \".\" or \"..\", we remove it from
766 | the resulting list.
767 | If FILEs are only \".\" or \"..\", return nil."
768 | (let (el dirs files)
769 | (while file-alist
770 | (if (or (eq (cadr (setq el (car file-alist))) t) ; directory
771 | (and (stringp (cadr el))
772 | (file-directory-p (cadr el)))) ; symlink to a directory
773 | (unless (member (car el) '("." ".."))
774 | (setq dirs (cons (car el) dirs)))
775 | (setq files (cons (car el) files)))
776 | (setq file-alist (cdr file-alist)))
777 | (nconc (nreverse dirs) (nreverse files))))
778 |
779 | (defun bfs-ls (dir)
780 | "Return the list of files in DIR.
781 | The list is sorted alphabetically with the directories first.
782 | Return nil, if DIR is empty.
783 |
784 | See `bfs-ls-group-directory-first'."
785 | (let ((file-alist
786 | (sort (directory-files-and-attributes dir)
787 | (lambda (x y) (ls-lisp-string-lessp (car x) (car y))))))
788 | (bfs-ls-group-directory-first file-alist)))
789 |
790 | (defun bfs-ls-child-filtered (dir)
791 | "Filter the list returned by `bfs-ls-child-function' applied to DIR.
792 | We apply `bfs-ls-child-filter-functions' filters."
793 | (if-let* ((filters bfs-ls-child-filter-functions)
794 | (filter (apply '-andfn filters)))
795 | (-filter filter (funcall bfs-ls-child-function dir))
796 | (funcall bfs-ls-child-function dir)))
797 |
798 | ;;; Format entries
799 |
800 | (defvar bfs-format-parent-entry-function
801 | 'bfs-format-entry-parent
802 | "Function that formats the lines to be displayed in
803 | `bfs-parent-buffer-name'.
804 |
805 | See `bfs-format-child-entry-function' to know how
806 | `bfs-format-parent-entry-function' must be defined. Not, that as
807 | we don't implement a mark system in `bfs-parent-buffer-name' buffer,
808 | in `bfs-format-parent-entry-function' function, you don't have
809 | to implement this functionality. Nevertheless, they both
810 | have the same signature.
811 |
812 | `bfs' provides 4 format functions for `bfs-parent-buffer-name':
813 | - `bfs-format-entry-parent',
814 | - `bfs-format-entry+size-parent',
815 | - `bfs-format-icon+entry-parent',
816 | - `bfs-format-icon+entry+size-parent'.")
817 |
818 | (defvar bfs-format-child-entry-function
819 | 'bfs-format-entry+size
820 | "Function that formats the lines to be displayed in
821 | `bfs-child-buffer-name'.
822 |
823 | The function is of the form:
824 | (entry dir &optional max-length mark) -> string
825 | 1. The returned string must have the text property 'bfs-file set
826 | to the concatenation of DIR and ENTRY,
827 | 2. The part of the returned string that correspond to ENTRY must
828 | have the text property 'bfs-entry set to ENTRY,
829 | 3. If MARK is t, the returned string must have the text property
830 | 'bfs-marked set to t,
831 | 4. If you add some info to the right of ENTRY in the returned string,
832 | you might want to add spaces between in order to verticaly
833 | align the information in the buffer. To do this, you can
834 | use MAX-LENGTH argument,that correspond to the longest string
835 | resulting of the concatenation of ENTRY and the info corresponding
836 | to the entry determined for all entries (filename) in DIR.
837 | See `bfs-max-length'.
838 |
839 | `bfs' provides 4 format functions for `bfs-parent-child-name':
840 | - `bfs-format-entry',
841 | - `bfs-format-entry+size',
842 | - `bfs-format-icon+entry',
843 | - `bfs-format-icon+entry+size'.")
844 |
845 | (defun bfs-space-between (len s1 s2)
846 | "Concatenate S1 and S2 with spaces in between.
847 | Add as many spaces as necessary to make the length of the
848 | resulting string equal to LEN.
849 | If LEN is too small, add only one space."
850 | (let ((space-nb (max 1 (- len (length (concat s1 s2))))))
851 | (concat s1 (make-string space-nb ?\ ) s2)))
852 |
853 | (defun bfs-size-or-number-of-files (file)
854 | "Return the size of FILE file in human readable format.
855 | If FILE is an accessible directory, return the number of files it contains.
856 | Return the empty string in any other cases."
857 | (cond ((file-regular-p file)
858 | (file-size-human-readable
859 | (file-attribute-size (file-attributes file)) nil " "))
860 | ((file-accessible-directory-p file)
861 | (number-to-string
862 | (length (--remove (member it '("." "..")) (directory-files file)))))
863 | (t "")))
864 |
865 | (defun bfs-max-length (dir in-buffer &optional is-root)
866 | "Longest length of the concatenation of entries in DIR and their size.
867 | The size is determine by the function `bfs-size-or-number-of-files'.
868 | The entries are obtain by listing DIR directory with:
869 | - `bfs-ls-child-filtered' if IN-BUFFER is 'child,
870 | - `bfs-ls-parent-function' if IN-BUFFER is 'parent.
871 | Return nil if there no file to list in DIR.
872 | When IS-ROOT t, we don't list DIR, and the calculation is done only on
873 | the entry DIR. This case happens when we are at the top of the file
874 | system and `bfs-parent-buffer-name' buffer has only the entry root and
875 | `bfs-child-buffer-name' list the files of root."
876 | (let ((filenames
877 | (cond ((equal in-buffer 'child) (bfs-ls-child-filtered dir))
878 | ((equal in-buffer 'parent) (funcall bfs-ls-parent-function dir)))))
879 | (if is-root
880 | (+ (length dir) (length (bfs-size-or-number-of-files dir)))
881 | (when filenames
882 | (-max (--map (+ (length it)
883 | (length
884 | (bfs-size-or-number-of-files (f-join dir it))))
885 | filenames))))))
886 |
887 | (defun bfs-format-entry (entry dir &optional _max-length mark)
888 | "Return the string ENTRY with some added text properties.
889 |
890 | Format ENTRY to be displayed in `bfs-child-buffer-name' buffer.
891 | ENTRY is a filename belonging to DIR directory.
892 | MAX-LENGTH argument isn't used.
893 | If MARK is t, it means the ENTRY is marked.
894 |
895 | See `bfs-format-child-entry-function'."
896 | (let* ((file (f-join dir entry))
897 | (bfs-entry
898 | (propertize
899 | (if mark (propertize entry 'font-lock-face 'bfs-mark) entry)
900 | 'bfs-entry entry))
901 | (left-pad
902 | (if mark (propertize "* " 'font-lock-face 'bfs-mark) " ")))
903 | (propertize (concat left-pad bfs-entry)
904 | 'bfs-file file
905 | 'bfs-marked mark)))
906 |
907 | (defun bfs-format-entry+size (entry dir &optional max-length mark)
908 | "Return the string ENTRY with the file size of ENTRY on the right.
909 |
910 | Format ENTRY to be displayed in `bfs-child-buffer-name' buffer.
911 | ENTRY is a filename belonging to DIR directory.
912 | MAX-LENGTH correspond to the value of `bfs-max-length'.
913 | If MARK is t, it means the ENTRY is marked.
914 |
915 | See `bfs-format-child-entry-function' and `bfs-size-or-number-of-files'."
916 | (let* ((left-pad (if mark (propertize "* " 'font-lock-face 'bfs-mark) " "))
917 | (file (f-join dir entry))
918 | (bfs-entry (propertize entry 'bfs-entry entry))
919 | (size (bfs-size-or-number-of-files file))
920 | (info (propertize size 'bfs-info t))
921 | (space-between
922 | (bfs-space-between (1+ (or max-length 0)) bfs-entry info))
923 | (entry+info (if mark
924 | (propertize space-between 'font-lock-face 'bfs-mark)
925 | space-between)))
926 | (propertize (concat left-pad entry+info)
927 | 'bfs-file file
928 | 'bfs-marked mark)))
929 |
930 | (defun bfs-format-entry-parent (entry dir &optional max-length mark)
931 | "A wrapper on `bfs-format-entry' where the left spaces are trimmed."
932 | (s-trim-left (bfs-format-entry entry dir max-length mark)))
933 |
934 | (defun bfs-format-entry+size-parent (entry dir &optional max-length mark)
935 | "A wrapper on `bfs-format-entry+size' where the left spaces are trimmed."
936 | (s-trim-left (bfs-format-entry+size entry dir max-length mark)))
937 |
938 | ;;;; All the icons
939 |
940 | (declare-function all-the-icons-icon-for-dir "ext:all-the-icons")
941 | (declare-function all-the-icons-icon-for-file "ext:all-the-icons")
942 |
943 | (defvar bfs-icon-v-adjust 0.01
944 | "The default vertical adjustment of the icon in `bfs-mode'.
945 | The variable is meaningful only if you have `all-the-icons' installed
946 | and at least one of the functions `bfs-format-child-entry-function'
947 | or `bfs-format-parent-entry-function' is a function that uses
948 | `all-the-icons'.
949 |
950 | See `bfs-format-icon+entry' and `bfs-icon'.")
951 |
952 | (defun bfs-icon (file &optional mark)
953 | "Return the icon string provide by `all-the-icons' corresponding to FILE.
954 | If MARK is true, the returned icon string has the face `bfs-mark'."
955 | (if (file-directory-p file)
956 | (all-the-icons-icon-for-dir
957 | file
958 | :face (or (and mark 'bfs-mark) 'bfs-directory)
959 | :v-adjust bfs-icon-v-adjust)
960 | (if mark (all-the-icons-icon-for-file
961 | file :face 'bfs-mark :v-adjust bfs-icon-v-adjust)
962 | (all-the-icons-icon-for-file file :v-adjust bfs-icon-v-adjust))))
963 |
964 | (defun bfs-format-icon+entry (entry dir &optional _max-length mark)
965 | "Return the string ENTRY preceded by the icon corresponding to ENTRY.
966 |
967 | Format ENTRY to be displayed in `bfs-child-buffer-name' buffer.
968 | ENTRY is a filename belonging to DIR directory.
969 | MAX-LENGTH argument isn't used.
970 | If MARK is t, it means the ENTRY is marked.
971 |
972 | See `bfs-format-child-entry-function' and `bfs-icon'."
973 | (let* ((file (f-join dir entry))
974 | (bfs-entry
975 | (propertize
976 | (if mark (propertize entry 'font-lock-face 'bfs-mark) entry)
977 | 'bfs-entry entry))
978 | (icon (bfs-icon file mark))
979 | (left-pad
980 | (if mark (propertize "* " 'font-lock-face 'bfs-mark) " ")))
981 | (propertize (concat left-pad icon "\t" bfs-entry)
982 | 'bfs-file file
983 | 'bfs-marked mark)))
984 |
985 | (defun bfs-format-icon+entry+size (entry dir &optional max-length mark)
986 | "Return the string ENTRY preceded by an icon and the file size at the end.
987 |
988 | Format ENTRY to be displayed in `bfs-child-buffer-name' buffer.
989 | ENTRY is a filename belonging to DIR directory.
990 | MAX-LENGTH correspond to the value of `bfs-max-length'.
991 | If MARK is t, it means the ENTRY is marked.
992 |
993 | See `bfs-format-child-entry-function', `bfs-icon' and
994 | `bfs-size-or-number-of-files'."
995 | (let* ((left-pad (if mark (propertize "* " 'font-lock-face 'bfs-mark) " "))
996 | (file (f-join dir entry))
997 | (bfs-entry (propertize entry 'bfs-entry entry))
998 | (icon (bfs-icon file mark))
999 | (size (bfs-size-or-number-of-files file))
1000 | (info (propertize size 'bfs-info t))
1001 | (space-between
1002 | (bfs-space-between (1+ (or max-length 0)) bfs-entry info))
1003 | (entry+info (if mark
1004 | (propertize space-between 'font-lock-face 'bfs-mark)
1005 | space-between)))
1006 | (propertize (concat left-pad icon "\t" entry+info)
1007 | 'bfs-file file
1008 | 'bfs-marked mark)))
1009 |
1010 | (defun bfs-format-icon+entry-parent (entry dir &optional max-length mark)
1011 | "A wrapper on `bfs-format-icon+entry' where the left spaces are trimmed."
1012 | (s-trim-left (bfs-format-icon+entry entry dir max-length mark)))
1013 |
1014 | (defun bfs-format-icon+entry+size-parent (entry dir &optional max-length mark)
1015 | "A wrapper on `bfs-format-icon+entry+size' where the left spaces are trimmed."
1016 | (s-trim-left (bfs-format-icon+entry+size entry dir max-length mark)))
1017 |
1018 | ;;; Mark entries
1019 |
1020 | (defface bfs-mark
1021 | '((t (:inherit dired-mark)))
1022 | "Face used for subdirectories."
1023 | :group 'bfs)
1024 |
1025 | (defvar bfs-regexp-history nil
1026 | "History list of regular expressions used by `bfs-mark-regex'.
1027 | This history is also used by `bfs-narrow'.")
1028 |
1029 | (defun bfs-entry-at-point ()
1030 | "Return entry on the line at `point'.
1031 | Return nil if there is no entry found."
1032 | (if-let ((entry-match
1033 | (save-excursion
1034 | (goto-char (point-at-bol))
1035 | (text-property-search-forward 'bfs-entry))))
1036 | (prop-match-value entry-match)))
1037 |
1038 | (defun bfs-mark ()
1039 | "Mark line at point."
1040 | (interactive)
1041 | (let ((inhibit-read-only t))
1042 | (when-let ((entry (bfs-entry-at-point)))
1043 | (save-excursion
1044 | (delete-and-extract-region (point-at-bol) (point-at-eol))
1045 | (insert (funcall bfs-format-child-entry-function
1046 | entry default-directory bfs-max-length t))))))
1047 |
1048 | (defun bfs-unmark ()
1049 | "Unmark line at point."
1050 | (interactive)
1051 | (let ((inhibit-read-only t))
1052 | (when-let ((entry (bfs-entry-at-point)))
1053 | (save-excursion
1054 | (delete-and-extract-region (point-at-bol) (point-at-eol))
1055 | (insert (funcall bfs-format-child-entry-function
1056 | entry default-directory bfs-max-length))
1057 | (font-lock-fontify-region (point-at-bol) (point-at-eol))))))
1058 |
1059 | (defun bfs-unmark-all ()
1060 | "Unmark all buffer."
1061 | (interactive)
1062 | (let ((inhibit-read-only t) entry)
1063 | (save-excursion
1064 | (goto-char (point-min))
1065 | (while (text-property-search-forward 'bfs-marked t t)
1066 | (setq entry (bfs-entry-at-point))
1067 | (delete-and-extract-region (point-at-bol) (point-at-eol))
1068 | (insert (funcall bfs-format-child-entry-function
1069 | entry default-directory bfs-max-length))))
1070 | (save-excursion
1071 | (font-lock-fontify-region (point-at-bol) (point-at-eol)))))
1072 |
1073 | (defun bfs-mark-regexp (regexp)
1074 | "Mark all files matching REGEXP.
1075 | REGEXP is matched against each bfs entry (filename).
1076 | REGEXP is an Emacs regexp, not a shell wildcard."
1077 | (interactive
1078 | (list (read-regexp "Mark files (regexp): " nil 'bfs-regexp-history)))
1079 | (save-excursion
1080 | (goto-char (point-min))
1081 | (let (entry-match)
1082 | (while (setq entry-match (text-property-search-forward 'bfs-entry))
1083 | (when-let* ((entry (prop-match-value entry-match))
1084 | ((string-match-p regexp entry)))
1085 | (bfs-mark)
1086 | (forward-line))))))
1087 |
1088 | (defun bfs-is-marked-p ()
1089 | "Return t if entry at point is marked."
1090 | (get-text-property (point-at-bol) 'bfs-marked))
1091 |
1092 | (defun bfs-toggle-marks ()
1093 | "Toggle mark in buffer."
1094 | (interactive)
1095 | (save-excursion
1096 | (goto-char (point-min))
1097 | (while (and (not (eobp)) (bfs-entry-at-point))
1098 | (if (bfs-is-marked-p) (bfs-unmark) (bfs-mark))
1099 | (forward-line))))
1100 |
1101 | (defun bfs-kill-marked ()
1102 | "Kill all marked entries (not the files)."
1103 | (interactive)
1104 | (let ((inhibit-read-only t))
1105 | (save-excursion
1106 | (goto-char (point-min))
1107 | (while (text-property-search-forward 'bfs-marked t t)
1108 | (delete-and-extract-region (point-at-bol) (line-beginning-position 2))))
1109 | (bfs-preview (bfs-child))))
1110 |
1111 | (defun bfs-list-marked (&optional entries)
1112 | "Return the list of marked files in `bfs-child-buffer-name' buffer.
1113 | Return nil if no files marked.
1114 |
1115 | If ENTRIES is non-nil, return entries (filenames) in the list (not files)."
1116 | (let (marked file)
1117 | (save-excursion
1118 | (goto-char (point-min))
1119 | (while (text-property-search-forward 'bfs-marked t t)
1120 | (if-let ((entries) (entry (bfs-entry-at-point)))
1121 | (push entry marked)
1122 | (and (setq file (get-text-property (point-at-bol) 'bfs-file))
1123 | (push file marked))))
1124 | (nreverse marked))))
1125 |
1126 | (defun bfs-revert (&optional _arg _noconfirm)
1127 | "Revert `bfs-child-buffer-name'.
1128 | Bfs entries that are marked are left marked."
1129 | (interactive)
1130 | (let* ((child (bfs-child))
1131 | (child-entry (bfs-entry-at-point))
1132 | (marked-entries (bfs-list-marked 'entries)))
1133 | (bfs-child-buffer default-directory child-entry marked-entries)
1134 | (bfs-preview child)))
1135 |
1136 | ;;; Filter entries in child buffer
1137 |
1138 | ;;;; Hide dotfiles in child buffer
1139 |
1140 | (defun bfs-hide-dotfiles-filter (filename)
1141 | "Return non-nil if FILENAME doesn't start with a \".\"."
1142 | (not (string-match-p "^\\." filename)))
1143 |
1144 | (defun bfs-hide-dotfiles ()
1145 | "Toggle visibility of dotfiles in `bfs-child-buffer-name'."
1146 | (interactive)
1147 | (if (member 'bfs-hide-dotfiles-filter bfs-ls-child-filter-functions)
1148 | (setq bfs-ls-child-filter-functions
1149 | (--remove (equal it 'bfs-hide-dotfiles-filter)
1150 | bfs-ls-child-filter-functions))
1151 | (push 'bfs-hide-dotfiles-filter bfs-ls-child-filter-functions))
1152 | (bfs-child-buffer default-directory
1153 | (or (and (bfs-child) (f-filename (bfs-child))) ""))
1154 | (bfs-preview (bfs-child)))
1155 |
1156 | ;;;; Narrow child buffer interactively
1157 |
1158 | (defvar bfs-narrow-current-regexp nil
1159 | "Regexp used to narrow child buffer dynamically.
1160 | This variable is set and used by `bfs-narrow-update'.
1161 | This is how we dynamically modify the filter function
1162 | `bfs-narrow-filter' and so narrow the child buffer.
1163 |
1164 | See `bfs-narrow'.")
1165 |
1166 | (defvar bfs-narrow-marked-entries nil
1167 | "List of marked entries before narrowing with `bfs-narrow'.")
1168 |
1169 | (defvar bfs-narrow-child-entry nil
1170 | "child before narrowing with `bfs-narrow'.")
1171 |
1172 | (defun bfs-narrow-filter (entry)
1173 | "Return t when `bfs-narrow-current-regexp' matches ENTRY.
1174 | Unconditionally return t when `bfs-narrow-current-regexp' isn't
1175 | a valid regexp.
1176 | This function is meant to be added to `bfs-ls-child-filter-functions'
1177 | temporary when we are dynamically narrowing the child buffer
1178 | with `bfs-narrow'."
1179 | (condition-case nil
1180 | (string-match-p bfs-narrow-current-regexp entry)
1181 | (error t)))
1182 |
1183 | (defun bfs-narrow-minibuffer-setup ()
1184 | "Set minibuffer for dynamic narrowing.
1185 | This function is meant to be added to the hook `minibuffer-setup-hook'.
1186 | See `bfs-narrow-update'."
1187 | (add-hook 'post-command-hook 'bfs-narrow-update nil 'local))
1188 |
1189 | (defun bfs-narrow-update ()
1190 | "Narrow the child buffer based on the contents of the minibuffer.
1191 | This function is meant to be added in the hook `post-command-hook'
1192 | locally in minibuffer. See `bfs-narrow-minibuffer-setup' and `bfs-narrow'.
1193 |
1194 | This function locally set `bfs-narrow-current-regexp'.
1195 | This function depends on the value of `bfs-narrow-child-entry' and
1196 | `bfs-narrow-marked-entries'."
1197 | (let* ((bfs-narrow-current-regexp (minibuffer-contents-no-properties))
1198 | (child-window (plist-get bfs-windows :child))
1199 | (child-entry (or (and (s-blank-p bfs-narrow-current-regexp)
1200 | bfs-narrow-child-entry)
1201 | (and (bfs-child) (f-filename (bfs-child))))))
1202 | (with-selected-window child-window
1203 | (bfs-child-buffer default-directory
1204 | child-entry
1205 | bfs-narrow-marked-entries)
1206 | (bfs-preview (bfs-child)))))
1207 |
1208 | (defun bfs-narrow ()
1209 | "Narrow bfs child buffer to filenames matching a regexp read from minibuffer.
1210 | See `bfs-narrow-filter', `bfs-narrow-update' and `bfs-narrow-minibuffer-setup'."
1211 | (interactive)
1212 | (let ((bfs-narrow-child-entry (and (bfs-child) (f-filename (bfs-child))))
1213 | quit-normaly-p)
1214 | (unwind-protect
1215 | (progn
1216 | (setq bfs-narrow-marked-entries (bfs-list-marked 'entries))
1217 | (add-hook 'minibuffer-setup-hook 'bfs-narrow-minibuffer-setup)
1218 | (push 'bfs-narrow-filter bfs-ls-child-filter-functions)
1219 | ;;`read-regexp' returns `nil' when minibuffer is quitted with C-g
1220 | (setq quit-normaly-p
1221 | (read-regexp "narrow files (regexp): "
1222 | nil 'bfs-regexp-history)))
1223 | (setq bfs-ls-child-filter-functions
1224 | (--remove (equal it 'bfs-narrow-filter)
1225 | bfs-ls-child-filter-functions))
1226 | (remove-hook 'minibuffer-setup-hook 'bfs-narrow-minibuffer-setup)
1227 | (if quit-normaly-p
1228 | (with-selected-window (plist-get bfs-windows :child)
1229 | (bfs-preview (bfs-child)))
1230 | (with-selected-window (plist-get bfs-windows :child)
1231 | (bfs-child-buffer default-directory
1232 | bfs-narrow-child-entry
1233 | bfs-narrow-marked-entries)
1234 | (bfs-preview (bfs-child))))
1235 | (setq bfs-narrow-current-regexp nil)
1236 | (setq bfs-narrow-marked-entries nil)
1237 | (setq bfs-narrow-child-entry nil))))
1238 |
1239 | ;;; Create top, parent, child and preview buffers
1240 |
1241 | (defvar bfs-top-buffer-name "*bfs-top*"
1242 | "Top buffer name.")
1243 |
1244 | (defvar bfs-parent-buffer-name "*bfs-parent*"
1245 | "Parent buffer name.")
1246 |
1247 | (defvar bfs-child-buffer-name "*bfs-child*"
1248 | "Child buffer name.")
1249 |
1250 | (defvar bfs-preview-buffer-name "*bfs-preview*"
1251 | "Preview buffer name when we are not visiting a file.
1252 | This buffer is used show informations explaining why
1253 | we are not previewing `bfs-child' file.")
1254 |
1255 | (defvar-local bfs-max-length
1256 | nil
1257 | "Hold the longest length of the concatenation of an entry and its info.
1258 | Entries are filenames (not the pathes), and infos can be file sizes, or
1259 | any information we might want to add on the right of the entry,
1260 | in `bfs-child-buffer-name' and `bfs-parent-buffer-name' buffers.
1261 |
1262 | The value of this local variable is computed by the function
1263 | `bfs-max-length'.
1264 |
1265 | See: `bfs-insert-ls-child'.")
1266 |
1267 | (defun bfs-insert-ls (dir in-buffer &optional is-root marked-entries)
1268 | "Insert directory listing for DIR.
1269 | Leave point after the inserted text.
1270 |
1271 | This function is used to fill `bfs-parent-buffer-name'
1272 | and `bfs-child-buffer-name' buffers depending on the
1273 | value of IN-BUFFER which can be 'child or 'parent.
1274 |
1275 | If IS-ROOT is non-nil, don't do the listing of DIR, and just
1276 | insert DIR in the buffer.
1277 |
1278 | If MARKED-ENTRIES is non-nil, this is a list of the entries
1279 | that must be marked in the child buffer (so it only works
1280 | with IN-BUFFER equal to 'child).
1281 |
1282 | See functions: `bfs-ls-parent-function', `bfs-ls-child-function',
1283 | `bfs-ls-child-filtered', `bfs-format-parent-entry-function',
1284 | `bfs-format-child-entry-function'."
1285 | (if is-root
1286 | (progn
1287 | (setq bfs-max-length (bfs-max-length dir 'parent 'is-root))
1288 | (insert (funcall bfs-format-parent-entry-function
1289 | dir dir bfs-max-length)))
1290 | (let (filenames format-entry)
1291 | (pcase in-buffer
1292 | ('parent
1293 | (setq filenames (funcall bfs-ls-parent-function dir))
1294 | (setq format-entry bfs-format-parent-entry-function)
1295 | (setq bfs-max-length (bfs-max-length dir 'parent)))
1296 | ('child
1297 | (setq filenames (bfs-ls-child-filtered dir))
1298 | (setq format-entry bfs-format-child-entry-function)
1299 | (setq bfs-max-length (bfs-max-length dir 'child))))
1300 | (insert (s-join "\n" (--map (funcall format-entry
1301 | it dir bfs-max-length
1302 | (and (member it marked-entries) t))
1303 | filenames)))))
1304 | (insert "\n"))
1305 |
1306 | (defun bfs-parent-buffer (parent)
1307 | "Produce `bfs-parent-buffer-name' buffer.
1308 | The produced buffer contains the listing of the parent directory of
1309 | PARENT and put the cursor at PARENT dirname."
1310 | (with-current-buffer (get-buffer-create bfs-parent-buffer-name)
1311 | (unless (bound-and-true-p bfs-parent-mode)
1312 | (bfs-parent-mode))
1313 | (let ((inhibit-read-only t))
1314 | (erase-buffer)
1315 | (cond
1316 | ((f-root-p parent)
1317 | (bfs-insert-ls parent 'parent 'is-root)
1318 | (bfs-goto-entry parent)
1319 | (setq default-directory parent))
1320 | (t (bfs-insert-ls (f-parent parent) 'parent)
1321 | (bfs-goto-entry (f-filename parent))
1322 | (setq default-directory (f-parent parent)))))
1323 | (bfs-line-highlight-parent))
1324 | (bury-buffer bfs-parent-buffer-name))
1325 |
1326 | (defun bfs-child-buffer (parent child-entry &optional marked-entries)
1327 | "Produce `bfs-child-buffer-name' buffer.
1328 | The produced buffer contains the listing of the directory PARENT
1329 | and put the cursor at CHILD-ENTRY.
1330 | If CHILD-ENTRY is nil, cursor is put in the first line (see `bfs-goto-entry')."
1331 | (with-current-buffer (get-buffer-create bfs-child-buffer-name)
1332 | (unless (bound-and-true-p bfs-mode)
1333 | (bfs-mode))
1334 | (let ((inhibit-read-only t))
1335 | (erase-buffer)
1336 | (bfs-insert-ls parent 'child nil marked-entries))
1337 | (setq-local default-directory parent)
1338 | (bfs-goto-entry child-entry)
1339 | ;; `bfs-line-highlight-child' depends on the faces
1340 | ;; font-lock adds to the text in the buffer. So,
1341 | ;; the buffer must be totally fontify before calling
1342 | ;; `bfs-line-highlight-child'.
1343 | (font-lock-ensure (point-min) (point-max))
1344 | (bfs-line-highlight-child))
1345 | (bury-buffer bfs-child-buffer-name))
1346 |
1347 | (defun bfs-top-line-truncate (len s)
1348 | "If S is longer than LEN, cut it down and add \"...\" to the beginning."
1349 | (let ((len-s (length s)))
1350 | (if (> len-s len)
1351 | (concat (propertize "..." 'face 'bfs-directory)
1352 | (substring s (- len-s (- len 3)) len-s))
1353 | s)))
1354 |
1355 | (defun bfs-top-line-default (child)
1356 | "Return the string of CHILD path formated to be used in `bfs-top-buffer-name'."
1357 | (let* ((parent (or (and (f-root-p (f-parent child)) (f-parent child))
1358 | (concat (f-parent child) "/")))
1359 | (filename (f-filename child))
1360 | (line (propertize parent 'font-lock-face 'bfs-top-parent-directory)))
1361 | (if-let ((target (file-symlink-p child)))
1362 | (-reduce
1363 | #'concat
1364 | `(,line
1365 | ,(propertize filename
1366 | 'font-lock-face (if (bfs-broken-symlink-p child)
1367 | 'bfs-top-broken-symlink
1368 | 'bfs-top-symlink-name))
1369 | ,(propertize " -> " 'font-lock-face 'bfs-top-symlink-arrow)
1370 | ,(propertize target
1371 | 'font-lock-face (cond ((bfs-broken-symlink-p child)
1372 | 'bfs-top-broken-symlink)
1373 | ((file-directory-p (file-truename child))
1374 | 'bfs-top-symlink-directory-target)
1375 | (t 'bfs-top-symlink-file-target)))))
1376 | (concat line (propertize filename 'font-lock-face 'bfs-top-child-entry)))))
1377 |
1378 | (defun bfs-top-line-ellipsed (child)
1379 | "Return `bfs-top-line-default' truncated with ellipses at the beginning.
1380 | The truncation is done only if `bfs-top-line-default' length showing CHILD
1381 | path is greater than the top window width."
1382 | (bfs-top-line-truncate (window-width (plist-get bfs-windows :top))
1383 | (bfs-top-line-default child)))
1384 |
1385 | (defun bfs-top-buffer (&optional child)
1386 | "Produce `bfs-top-buffer-name' buffer showing CHILD file information."
1387 | (with-current-buffer (get-buffer-create bfs-top-buffer-name)
1388 | (read-only-mode -1)
1389 | (erase-buffer)
1390 | (if-let ((child (or child (bfs-child))))
1391 | (insert (funcall bfs-top-line-function child))
1392 | (insert "No child entry to be previewed"))
1393 | (bfs-top-mode))
1394 | (bury-buffer bfs-top-buffer-name))
1395 |
1396 | (defvar-local bfs-preview-buffer-file-name nil)
1397 |
1398 | (defun bfs-preview-buffer (child reason)
1399 | "Produce `bfs-preview-buffer-name' buffer.
1400 | Insert REASON string into the buffer that expresses why we
1401 | don't visit CHILD as any regular file."
1402 | (with-current-buffer (get-buffer-create bfs-preview-buffer-name)
1403 | (read-only-mode -1)
1404 | (erase-buffer)
1405 | (insert reason)
1406 | (bfs-preview-mode)
1407 | (if child
1408 | (setq-local bfs-preview-buffer-file-name (file-truename child))
1409 | (setq-local bfs-preview-buffer-file-name 'no-child-entry)))
1410 | (bury-buffer bfs-preview-buffer-name))
1411 |
1412 | ;;; Display
1413 |
1414 | (defvar bfs-top-window-parameters
1415 | '(display-buffer-in-side-window
1416 | (side . top)
1417 | (window-height . 2)
1418 | (window-parameters . ((no-other-window . t)))))
1419 |
1420 | (defvar bfs-parent-window-parameters
1421 | '(display-buffer-in-side-window
1422 | (side . left)
1423 | (window-width . 0.2)
1424 | (window-parameters . ((no-other-window . t)))))
1425 |
1426 | (defvar bfs-child-window-parameters '(display-buffer-same-window))
1427 |
1428 | (defvar bfs-preview-window-parameters
1429 | '(display-buffer-in-direction
1430 | (direction . right)
1431 | (window-width . 0.6)))
1432 |
1433 | (defvar bfs-frame nil
1434 | "Frame where the `bfs' environment has been started.
1435 | Used internally.")
1436 |
1437 | (defvar bfs-windows nil
1438 | "Plist that store `bfs' windows information.
1439 | Used internally.
1440 | Properties of this plist are: :top, :parent, :child, :preview.")
1441 |
1442 | (defvar bfs-visited-file-buffers nil
1443 | "List of live buffers visited with `bfs-preview'during a `bfs' session.
1444 | Used internally.")
1445 |
1446 | (defun bfs-top-update ()
1447 | "Update `bfs-top-buffer-name' and redisplay it."
1448 | (bfs-top-buffer)
1449 | (with-selected-frame bfs-frame
1450 | (display-buffer bfs-top-buffer-name
1451 | bfs-top-window-parameters)))
1452 |
1453 | (defun bfs-preview (child &optional first-time)
1454 | "Preview file CHILD on the right window.
1455 | When FIRST-TIME is non-nil, set the window layout."
1456 | (let (preview-window preview-file-buffer (preview-update t))
1457 | (cond ((and (not first-time)
1458 | (null child))
1459 | (bfs-preview-buffer child "No child entry to be previewed"))
1460 | ((and (not first-time)
1461 | (bfs-preview-matches-child-p)
1462 | (not (bfs-broken-symlink-p child)))
1463 | (setq preview-update nil))
1464 | ((member (file-name-extension child) bfs-ignored-extensions)
1465 | (bfs-preview-buffer child
1466 | (format "File ignored due to its extension: %s"
1467 | (file-name-extension child))))
1468 | ((and (file-exists-p child) bfs-max-size
1469 | (> (file-attribute-size (file-attributes (file-truename child)))
1470 | bfs-max-size))
1471 | (bfs-preview-buffer child
1472 | (format "File ignored due to its size: %s"
1473 | (file-size-human-readable
1474 | (file-attribute-size
1475 | (file-attributes (file-truename child)))))))
1476 | ((bfs-broken-symlink-p child)
1477 | (bfs-preview-buffer child "Symlink is broken"))
1478 | (t
1479 | (condition-case err
1480 | (progn
1481 | (setq preview-file-buffer
1482 | (find-file-noselect (or (file-symlink-p child) child)))
1483 | (setq bfs-visited (-uniq (cons child bfs-visited))))
1484 | (file-error
1485 | (bfs-preview-buffer child (error-message-string err))
1486 | (if first-time
1487 | (display-buffer (get-buffer bfs-preview-buffer-name)
1488 | bfs-preview-window-parameters)
1489 | (display-buffer (get-buffer bfs-preview-buffer-name) t))
1490 | (with-current-buffer bfs-child-buffer-name
1491 | (bfs-line-highlight-child))))))
1492 | (when preview-update
1493 | (if preview-file-buffer
1494 | (progn
1495 | (setq preview-window
1496 | (if first-time
1497 | (display-buffer preview-file-buffer
1498 | bfs-preview-window-parameters)
1499 | (display-buffer preview-file-buffer t)))
1500 | (when (and bfs-kill-buffer-eagerly bfs-visited-file-buffers)
1501 | (kill-buffer (pop bfs-visited-file-buffers)))
1502 | (unless (-contains-p
1503 | (-union (plist-get bfs-state-before :buffer-list)
1504 | bfs-visited-file-buffers)
1505 | preview-file-buffer)
1506 | (push preview-file-buffer bfs-visited-file-buffers)))
1507 | (if first-time
1508 | (display-buffer (get-buffer bfs-preview-buffer-name)
1509 | bfs-preview-window-parameters)
1510 | (display-buffer (get-buffer bfs-preview-buffer-name) t))))
1511 | (bfs-top-update)
1512 | preview-window))
1513 |
1514 | (defun bfs-update (child)
1515 | "Update `bfs' environment according to CHILD file."
1516 | (when (bfs-valid-child-p child)
1517 | (let ((inhibit-message t)
1518 | (parent (f-dirname child))
1519 | (child-entry (f-filename child)))
1520 | (bfs-parent-buffer parent)
1521 | (bfs-child-buffer parent child-entry)
1522 | (bfs-top-update)
1523 | (if (bfs-ls-child-filtered parent)
1524 | (bfs-preview child)
1525 | (bfs-preview nil)))))
1526 |
1527 | (defun bfs-display (child)
1528 | "Display `bfs' buffers in the current windows according to CHILD.
1529 | CHILD must be a file. Intended to be called only once in `bfs'."
1530 | (when (window-parameter (selected-window) 'window-side)
1531 | (other-window 1))
1532 | (delete-other-windows)
1533 | (bfs-top-buffer child)
1534 | (bfs-parent-buffer (f-dirname child))
1535 | (bfs-child-buffer (f-dirname child) (f-filename child))
1536 | (setq bfs-frame (selected-frame))
1537 | (setq bfs-windows
1538 | (plist-put bfs-windows
1539 | :top (display-buffer
1540 | bfs-top-buffer-name
1541 | bfs-top-window-parameters)))
1542 | (setq bfs-windows
1543 | (plist-put bfs-windows
1544 | :parent (display-buffer
1545 | bfs-parent-buffer-name
1546 | bfs-parent-window-parameters)))
1547 | (setq bfs-windows
1548 | (plist-put bfs-windows
1549 | :child (display-buffer
1550 | bfs-child-buffer-name
1551 | bfs-child-window-parameters)))
1552 | (setq bfs-windows
1553 | (plist-put bfs-windows
1554 | :preview (bfs-preview child t))))
1555 |
1556 | ;;; Leave bfs
1557 |
1558 | (defvar bfs-do-not-check-after
1559 | '(bfs
1560 | bfs-previous bfs-next bfs-backward bfs-forward
1561 | bfs-scroll-down-half-window
1562 | bfs-scroll-up-half-window
1563 | bfs-beginning-of-buffer
1564 | bfs-end-of-buffer
1565 | isearch-forward
1566 | isearch-repeat-forward
1567 | isearch-repeat-backward
1568 | isearch-backward
1569 | bfs-find-file
1570 | bfs-hide-dotfiles)
1571 | "List of commands after which we don't want to check `bfs' validity.")
1572 |
1573 | (defun bfs-valid-layout-p ()
1574 | "Return t if the window layout in `bfs-frame' frame is valid."
1575 | (let ((parent-win (plist-get bfs-windows :parent))
1576 | (child-win (plist-get bfs-windows :child))
1577 | (preview-win (plist-get bfs-windows :preview))
1578 | (normal-window-list
1579 | ;; we want the bfs layout to be valid when either `transient' or
1580 | ;; `hydra' (when using lv-message, see `hydra-hint-display-type'
1581 | ;; and `lv') package pops up a window. So we don't take those
1582 | ;; popped up windows into account to validate the layout.
1583 | (--remove (member (buffer-name (window-buffer it))
1584 | '(" *transient*" " *LV*"))
1585 | (window-list))))
1586 | (when (-all-p 'window-live-p `(,parent-win ,child-win ,preview-win))
1587 | (and (equal (length normal-window-list) 4)
1588 | (string= (buffer-name (window-buffer (window-in-direction 'right parent-win)))
1589 | bfs-child-buffer-name)
1590 | (string= (buffer-name (window-buffer (window-in-direction 'right preview-win t nil t)))
1591 | bfs-parent-buffer-name)))))
1592 |
1593 | (defun bfs-check-environment ()
1594 | "Leave `bfs' environment if it isn't valid.
1595 |
1596 | We use `bfs-check-environment' in `window-configuration-change-hook'.
1597 | This ensure not to end in an inconsistent (unwanted) Emacs state
1598 | after running any command that invalidate `bfs' environment.
1599 |
1600 | For instance, your `bfs' environment stops to be valid:
1601 | 1. when you switch to a buffer not attached to a file,
1602 | 2. when you modify the layout deleting or rotating windows,
1603 | 3. when you run any command that makes the previewed buffer
1604 | no longer match the child entry.
1605 |
1606 | See `bfs-valid-layout-p' and `bfs-preview-matches-child-p'."
1607 | (cond
1608 | ((or (window-minibuffer-p)
1609 | (not (eq (selected-frame) bfs-frame))
1610 | (memq last-command bfs-do-not-check-after))
1611 | nil)
1612 | ((or (not (bfs-valid-layout-p))
1613 | (not (bfs-preview-matches-child-p)))
1614 | (bfs-clean)
1615 | (when (window-parameter (selected-window) 'window-side)
1616 | (other-window 1))
1617 | (delete-other-windows))
1618 | (t nil)))
1619 |
1620 | (defun bfs-clean-if-frame-deleted (_frame)
1621 | "Clean `bfs' environment if the frame that was running it has been deleted.
1622 | Intended to be added to `after-delete-frame-functions'."
1623 | (unless (frame-live-p bfs-frame)
1624 | (bfs-clean)))
1625 |
1626 | (defun bfs-kill-visited-file-buffers ()
1627 | "Kill the buffers used to preview files with `bfs-preview'.
1628 | This doesn't kill buffers in (plist-get bfs-state-before :buffer-list)
1629 | that was lived before entering in the `bfs' environment.
1630 | See: `bfs-state-before'."
1631 | (-each (-difference bfs-visited-file-buffers
1632 | (plist-get bfs-state-before :buffer-list))
1633 | 'kill-buffer)
1634 | (setq bfs-visited-file-buffers nil))
1635 |
1636 | (defun bfs-clean ()
1637 | "Leave `bfs' environment and clean Emacs state."
1638 | (unless (window-minibuffer-p)
1639 | (setq bfs-is-active nil)
1640 | (remove-function after-delete-frame-functions 'bfs-clean-if-frame-deleted)
1641 | (remove-hook 'window-configuration-change-hook 'bfs-check-environment)
1642 | (remove-hook 'isearch-mode-end-hook 'bfs-isearch-preview-update)
1643 | (remove-hook 'isearch-update-post-hook 'bfs-isearch-preview-update)
1644 | (remove-hook 'window-state-change-hook 'bfs-top-update)
1645 | (setq bfs-frame nil)
1646 | (setq bfs-windows nil)
1647 | (bfs-kill-visited-file-buffers)
1648 | (setq window-sides-vertical
1649 | (plist-get bfs-state-before :window-sides-vertical))
1650 | (setq find-file-run-dired
1651 | (plist-get bfs-state-before :find-file-run-dired))
1652 | (when (bound-and-true-p which-key-mode)
1653 | (setq which-key-popup-type
1654 | (plist-get bfs-state-before :which-key-popup-type)))
1655 | (setq bfs-state-before nil)
1656 | (remove-hook 'dired-mode-hook 'bfs-dired-hide-details)
1657 | (when (get-buffer bfs-parent-buffer-name)
1658 | (kill-buffer bfs-parent-buffer-name))
1659 | (when (get-buffer bfs-child-buffer-name)
1660 | (kill-buffer bfs-child-buffer-name))
1661 | (when (get-buffer bfs-top-buffer-name)
1662 | (kill-buffer bfs-top-buffer-name))
1663 | (when (get-buffer bfs-preview-buffer-name)
1664 | (kill-buffer bfs-preview-buffer-name))))
1665 |
1666 | (defun bfs-quit ()
1667 | "Leave `bfs-mode' and restore previous window configuration."
1668 | (interactive)
1669 | (bfs-clean)
1670 | (jump-to-register :bfs))
1671 |
1672 | ;;; bfs (main entry)
1673 |
1674 | (defvar bfs-is-active nil
1675 | "Non-nil means that `bfs' environment is active in `bfs-frame'.
1676 | Used internally.")
1677 |
1678 | (defvar bfs-state-before nil
1679 | "Store partial emacs user state before entering `bfs' environment.
1680 | `bfs-state-before' is a property list used internally where:
1681 | :buffer-list is for evalutaion of (buffer-list),
1682 | :window-sides-vertical for the variable `window-sides-vertical',
1683 | :find-file-run-dired for the variable `find-file-run-dired',
1684 | :which-key-popup-type for the variable `which-key-popup-type'.")
1685 |
1686 | ;;;###autoload
1687 | (defun bfs (&optional file)
1688 | "Start a `bfs' (Browse File System) environment in the `selected-frame'.
1689 |
1690 | This pops up a 3 panes (windows) layout that allow you to browse
1691 | your file system and preview files.
1692 |
1693 | If FILE (a file name) is given:
1694 | - if it is a file, preview it in the right window,
1695 | - if it is a directory, list it in the child window.
1696 |
1697 | You can only have one `bfs' environment running at a time.
1698 |
1699 | If you call `bfs' with universal argument, `bfs' starts with
1700 | the filename of the `current-buffer' in the child window
1701 | (see `bfs-child-default').
1702 |
1703 | If you call `bfs' without universal argument, `bfs' starts with
1704 | the last file you've visited in the `bfs' environment
1705 | (see `bfs-visited' and `bfs-visit').
1706 |
1707 | When you are in the child window (the middle window), you can:
1708 | - quit `bfs' environment with `bfs-quit',
1709 | - preview files with `bfs-next' and `bfs-previous',
1710 | - go up and down in the file system tree with `bfs-backward'
1711 | and `bfs-forward',
1712 | - scroll the previewed file with `bfs-scroll-preview-down-half-window',
1713 | `bfs-scroll-preview-up-half-window',
1714 | - \"jump\" to any file in your file system with `bfs-find-file', this
1715 | automatically update `bfs' environment.
1716 |
1717 | In the child window, when you move the cursor with functions `isearch-forward'
1718 | or `isearch-backward', this will automatically preview the file you
1719 | move to.
1720 |
1721 | Any command that invalidates `bfs' environment will cause to leave
1722 | `bfs' environment. See `bfs-check-environment'.
1723 |
1724 | In the child window, the local keymap in use is `bfs-mode-map':
1725 |
1726 | \\{bfs-mode-map}."
1727 | (interactive)
1728 | (cond
1729 | (bfs-is-active
1730 | (when (eq (selected-frame) bfs-frame)
1731 | (bfs-quit)))
1732 | (t
1733 | (let (child)
1734 |
1735 | ;; set `child'
1736 | (cond (current-prefix-arg
1737 | (setq child (bfs-child-default (current-buffer))))
1738 | (file
1739 | (if (and (file-directory-p file)
1740 | (bfs-first-valid-child file))
1741 | (setq child (bfs-first-valid-child file))
1742 | (setq child file))
1743 | ;; to prevent `bfs-check-environment' to check `bfs'
1744 | ;; environment when we are building it for the first time
1745 | (setq this-command 'bfs))
1746 | ((and (car bfs-visited)
1747 | (bfs-valid-child-p (car bfs-visited)))
1748 | (setq child (car bfs-visited)))
1749 | (t (setq child (bfs-child-default (current-buffer)))))
1750 |
1751 | ;; active `bfs'
1752 | (condition-case-unless-debug err
1753 | (when (and child (bfs-valid-child-p child))
1754 | (setq bfs-is-active t)
1755 | (window-configuration-to-register :bfs)
1756 | (setq bfs-state-before
1757 | `(:buffer-list ,(buffer-list)
1758 | :window-sides-vertical ,window-sides-vertical
1759 | :find-file-run-dired ,find-file-run-dired))
1760 | (setq window-sides-vertical nil)
1761 | (setq find-file-run-dired t)
1762 | (when (bound-and-true-p which-key-mode)
1763 | (setq bfs-state-before
1764 | (plist-put bfs-state-before
1765 | :which-key-popup-type which-key-popup-type))
1766 | (setq which-key-popup-type 'minibuffer))
1767 | (when bfs-dired-hide-details
1768 | ;; the depth 99 is because we want to be sure that
1769 | ;; `bfs-dired-hide-details' is called last and
1770 | ;; so override `dired-hide-details-mode'.
1771 | (add-hook 'dired-mode-hook 'bfs-dired-hide-details 99))
1772 | (bfs-display child)
1773 | (add-function :before after-delete-frame-functions 'bfs-clean-if-frame-deleted)
1774 | (add-hook 'window-configuration-change-hook 'bfs-check-environment)
1775 | (add-hook 'isearch-mode-end-hook 'bfs-isearch-preview-update)
1776 | (add-hook 'isearch-update-post-hook 'bfs-isearch-preview-update)
1777 | (add-hook 'window-state-change-hook 'bfs-top-update))
1778 | (error
1779 | (bfs-quit)
1780 | (message "error with `bfs': %s" err)))))))
1781 |
1782 | ;;; Footer
1783 |
1784 | (provide 'bfs)
1785 |
1786 | ;;; bfs.el ends here
1787 |
--------------------------------------------------------------------------------
/bfs.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/tonyaldon/bfs/ab6d25366ea51ca720849c7a87e693d2efdf2eab/bfs.png
--------------------------------------------------------------------------------