├── .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 | ![bfs](./bfs.png) 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 --------------------------------------------------------------------------------