From 7752b5f686a11cbcb0e3d969efd03e2ad615ce3a Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sun, 29 May 2016 10:05:12 +0200 Subject: [PATCH 001/312] Add GPL. --- COPYING | 674 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 674 insertions(+) create mode 100644 COPYING diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..94a9ed0 --- /dev/null +++ b/COPYING @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. From a431a841617a9a7d675c0a2417e0085eeb09f59d Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Fri, 6 May 2016 23:53:03 +0200 Subject: [PATCH 002/312] PEG shell grammar. --- README | 7 ++ sh.bnf | 205 +++++++++++++++++++++++++++++++++++++++++++++++++++++ sh.peg.scm | 106 +++++++++++++++++++++++++++ test.sh | 74 +++++++++++++++++++ 4 files changed, 392 insertions(+) create mode 100644 README create mode 100644 sh.bnf create mode 100644 sh.peg.scm create mode 100644 test.sh diff --git a/README b/README new file mode 100644 index 0000000..ee9944a --- /dev/null +++ b/README @@ -0,0 +1,7 @@ +ANGUISH that which one might experience when their shell lacks a programming language +or +ANother GUIle SHell + +This project aims to produce at least a POSIX compliant sh +replacement. On top of that it also intends to make scheme available +for interactive and scripting application. diff --git a/sh.bnf b/sh.bnf new file mode 100644 index 0000000..b69a5e1 --- /dev/null +++ b/sh.bnf @@ -0,0 +1,205 @@ +/* ------------------------------------------------------- + The grammar symbols + ------------------------------------------------------- */ +%token WORD +%token ASSIGNMENT_WORD +%token NAME +%token NEWLINE +%token IO_NUMBER + + +/* The following are the operators mentioned above. */ + + +%token AND_IF OR_IF DSEMI +/* '&&' '||' ';;' */ + + +%token DLESS DGREAT LESSAND GREATAND LESSGREAT DLESSDASH +/* '<<' '>>' '<&' '>&' '<>' '<<-' */ + + +%token CLOBBER +/* '>|' */ + + +/* The following are the reserved words. */ + + +%token If Then Else Elif Fi Do Done +/* 'if' 'then' 'else' 'elif' 'fi' 'do' 'done' */ + + +%token Case Esac While Until For +/* 'case' 'esac' 'while' 'until' 'for' */ + + +/* These are reserved words, not operator tokens, and are + recognized when reserved words are recognized. */ + + +%token Lbrace Rbrace Bang +/* '{' '}' '!' */ + + +%token In +/* 'in' */ + +/* ------------------------------------------------------- + The Grammar + ------------------------------------------------------- */ +%start complete_command +%% +complete_command : list separator + | list + ; +list : list separator_op and_or + | and_or + ; +and_or : pipeline + | and_or AND_IF linebreak pipeline + | and_or OR_IF linebreak pipeline + ; +pipeline : pipe_sequence + | Bang pipe_sequence + ; +pipe_sequence : command + | pipe_sequence '|' linebreak command + ; +command : simple_command + | compound_command + | compound_command redirect_list + | function_definition + ; +compound_command : brace_group + | subshell + | for_clause + | case_clause + | if_clause + | while_clause + | until_clause + ; +subshell : '(' compound_list ')' + ; +compound_list : term + | newline_list term + | term separator + | newline_list term separator + ; +term : term separator and_or + | and_or + ; +for_clause : For name linebreak do_group + | For name linebreak in sequential_sep do_group + | For name linebreak in wordlist sequential_sep do_group + ; +name : NAME /* Apply rule 5 */ + ; +in : In /* Apply rule 6 */ + ; +wordlist : wordlist WORD + | WORD + ; +case_clause : Case WORD linebreak in linebreak case_list Esac + | Case WORD linebreak in linebreak case_list_ns Esac + | Case WORD linebreak in linebreak Esac + ; +case_list_ns : case_list case_item_ns + | case_item_ns + ; +case_list : case_list case_item + | case_item + ; +case_item_ns : pattern ')' linebreak + | pattern ')' compound_list linebreak + | '(' pattern ')' linebreak + | '(' pattern ')' compound_list linebreak + ; +case_item : pattern ')' linebreak DSEMI linebreak + | pattern ')' compound_list DSEMI linebreak + | '(' pattern ')' linebreak DSEMI linebreak + | '(' pattern ')' compound_list DSEMI linebreak + ; +pattern : WORD /* Apply rule 4 */ + | pattern '|' WORD /* Do not apply rule 4 */ + ; +if_clause : If compound_list Then compound_list else_part Fi + | If compound_list Then compound_list Fi + ; +else_part : Elif compound_list Then compound_list + | Elif compound_list Then compound_list else_part + | Else compound_list + ; +while_clause : While compound_list do_group + ; +until_clause : Until compound_list do_group + ; +function_definition : fname '(' ')' linebreak function_body + ; +function_body : compound_command /* Apply rule 9 */ + | compound_command redirect_list /* Apply rule 9 */ + ; +fname : NAME /* Apply rule 8 */ + ; +brace_group : Lbrace compound_list Rbrace + ; +do_group : Do compound_list Done /* Apply rule 6 */ + ; +simple_command : cmd_prefix cmd_word cmd_suffix + | cmd_prefix cmd_word + | cmd_prefix + | cmd_name cmd_suffix + | cmd_name + ; +cmd_name : WORD /* Apply rule 7a */ + ; +cmd_word : WORD /* Apply rule 7b */ + ; +cmd_prefix : io_redirect + | cmd_prefix io_redirect + | ASSIGNMENT_WORD + | cmd_prefix ASSIGNMENT_WORD + ; +cmd_suffix : io_redirect + | cmd_suffix io_redirect + | WORD + | cmd_suffix WORD + ; +redirect_list : io_redirect + | redirect_list io_redirect + ; +io_redirect : io_file + | IO_NUMBER io_file + | io_here + | IO_NUMBER io_here + ; +io_file : '<' filename + | LESSAND filename + | '>' filename + | GREATAND filename + | DGREAT filename + | LESSGREAT filename + | CLOBBER filename + ; +filename : WORD /* Apply rule 2 */ + ; +io_here : DLESS here_end + | DLESSDASH here_end + ; +here_end : WORD /* Apply rule 3 */ + ; +newline_list : NEWLINE + | newline_list NEWLINE + ; +linebreak : newline_list + | /* empty */ + ; +separator_op : '&' + | ';' + ; +separator : separator_op linebreak + | newline_list + ; +sequential_sep : ';' linebreak + | newline_list + ; diff --git a/sh.peg.scm b/sh.peg.scm new file mode 100644 index 0000000..e457cdb --- /dev/null +++ b/sh.peg.scm @@ -0,0 +1,106 @@ +(use-modules (ice-9 peg)) +(use-modules (ice-9 peg codegen)) +(use-modules (ice-9 pretty-print)) +(use-modules (ice-9 rdelim)) +(use-modules (ice-9 match)) + + +(define (remove-shell-comments s) + (string-join (map + (lambda (s) + (let* ((n (string-index s #\#))) + (if n (string-pad-right s (string-length s) #\space 0 n) + s))) + (string-split s #\newline)) "\n")) + +(define (flatten lst) + (cond + ((null? lst) + '()) + ((list? (car lst)) + (append (flatten (car lst)) (flatten (cdr lst)))) + (else + (cons (car lst) (flatten (cdr lst)))))) + +(define (sh-exec ast) + (define (sh-exec- ast) + (match ast + (('name o) o) + (('word o) o) + (('command o ...) (map sh-exec- o)) + ((head tail ...) (map sh-exec- (append (list head) tail))) + ;;(('list o ...) (map sh-exec o)) + ((_ o) (sh-exec- o)) + (_ #f))) + (let ((cmd (filter identity (flatten (sh-exec- ast))))) + cmd + (apply system* cmd) + )) + +;; insert / error at convenient location to short circuit backtracking +(define (parse input) +(define-peg-string-patterns +"script <-- (sp / linebreak)* (term (separator term)* separator?)? + term <-- pipeline (sp* (and / or) (sp / linebreak)* pipeline)* + and <-- '&&' + or <-- '||' + pipeline <-- '!'? sp* command (sp* pipe (sp / linebreak)* command)* + pipe <-- '|' + command <-- simple-command / (compound-command (sp+ io-redirect)*) / function-def + compound-command <-- brace-group / subshell / for-clause / case-clause / if-clause / while-clause / until-clause + subshell <-- '(' sp* compound-list sp* ')' + compound-list <-- (sp / linebreak)* term (separator term)* separator? + case-clause <-- 'case' sp+ word (sp / linebreak)* 'in' (sp / linebreak)* (case-item sp)* 'esac' + case-item <-- '('? sp* pattern sp* ')' (((sp / linebreak) ';;' (sp / linebreak)) / ((compound-list sp* ';;'?)? (sp / linebreak))) + pattern <-- word (sp* '|' sp* word)* + for-clause <-- 'for' sp+ identifier (sp / linebreak)+ ('in' (sp+ word)* sp* sequential-sep)? do-group + do-group <-- 'do' compound-list 'done' + if-clause <-- 'if' compound-list 'then' compound-list else-part? 'fi' + else-part <-- ('elif' compound-list 'then' compound-list else-part?) / ('else' compound-list) + while-clause <-- 'while' compound-list do-group + until-clause <-- 'until' compound-list do-group + function-def <-- name sp* '(' sp* ')' (sp / linebreak)* function-body + function-body <-- compound-command io-redirect* + brace-group <-- '{' sp* compound-list sp* '}' + simple-command <-- (io-redirect sp+)* !reserved word (sp+ (io-redirect / (!reserved word)))* + xsimple-command <-- !reserved ((cmd-prefix (sp+ cmd-suffix)?) / (word (sp+ cmd-suffix)?)) + reserved < ('if' / 'then' / 'else' / 'elif' / 'fi' / 'for' / 'done' / 'do' / 'until' / 'while') (sp / linebreak) + cmd-prefix <-- (io-redirect (sp* io-redirect)*) / (word (sp+ word)*) + cmd-suffix <-- (io-redirect (sp* io-redirect)*) / (word (sp+ word)*) + io-redirect <-- [0-9]* sp* (io-here / io-file) + io-file <-- ('<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|') sp* ([0-9]+ / filename) + filename <-- word + io-here <-- ('<<' / '<<-') sp* word + name <-- identifier + identifier <-- [_a-zA-Z][_a-zA-Z0-9]* + word <-- test / substitution / assignment / literal + test <-- ltest (!' ]' .)* rtest + ltest < '[ ' + rtest < ' ]' + substitution <-- ('$' '(' script ')') / ('`' word (sp+ word)* '`') + assignment <-- name assign word? + assign < '=' + literal <- (subst / delim / (![0-9] (!sp !linebreak ![;&|$()=] .)+) / ([0-9]+ &separator)) literal* + subst <- '$' ('$' / '*' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) + delim <- (['] (!['] .)* [']) / ([\"] (![\"] .)* [\"]) / ([`] (![`] .)* [`]) + separator <-- (sp* break (sp / linebreak)*) / (sp / linebreak)+ + break <-- '&' / ';' + sequential-sep <-- (semi (sp / linebreak)*) / (sp / linebreak)+ + semi < ';' + linebreak < [\r\n] + sp < [\t ]") +(let ((match (match-pattern script input))) + (if (not (eq? (string-length input) (peg:end match))) + (let ((tree (peg:tree match))) + (pretty-print (peg:tree match)) + (pretty-print "parse error" (current-error-port)) + (pretty-print (peg:end match))) + (peg:tree match)))) + + +;; (let* ((input (read-string (open-input-file (cadr (command-line))))) +;; (input (remove-shell-comments input)) +;; (ast (parse input))) +;; (sh-exec ast)) + +(pretty-print (parse (remove-shell-comments (read-string (open-input-file (cadr (command-line))))))) diff --git a/test.sh b/test.sh new file mode 100644 index 0000000..c5d7d54 --- /dev/null +++ b/test.sh @@ -0,0 +1,74 @@ +for file in $(find * -type f) +do + if [ "${file}" != "generator.log"\ + -a "${file}" != "gaiag.log"\ + -a "${file}" != "${basename}.scm"\ + -a "`basename ${file} .dzn`.dzn" != "${file}" ] + then + filecount=$((filecount+1)) + #files[${filecount}]=${file} + fi +done + +echo foo 2>&1 +ls -l / -1 + +(echo; echo) + +if true +then + echo +fi + +for f in foo; do echo; done + +for file in *.im +do + ${bin}/asd -l gen2 ${file} 2>&1 codegenerator.log || error "codegenerator gen2 failure: ${file}" codegenerator.log +done + +cat foo || echo ok && echo nok + +foo=$* +foo=$@ +foo=$(dirname $(dirname $@)) + +foo || bar && baz + +${bin}/generate -p componentfile.dzn > pretty.dzn 2> pretty.err && cat pretty.dzn || cat componentfile.dzn + +filecount=-1 + +if [ "${file}" != "generator.log"\ + -a "${file}" != "gaiag.log"\ + -a "${file}" != "${basename}.scm"\ + -a "`basename ${file} .dzn`.dzn" != "${file}" ] +then + echo + filecount=$((filecount+1)) + #files[${filecount}]=${file} +fi + + +for file in $(find * -type f) +do + echo +done + +for file in $(find * -type f) +do + echo $file +done + +if ls& ls; then echo foo& echo bar || echo foo; echo barf; fi + +for f in foo bar; do echo; done +ls + +model=$1 +model= + +if [ "${model}" = "" ] +then + echo +fi From 055aed15999c89db6540ba08c15c50a59f15a7d4 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Fri, 20 May 2016 00:01:52 +0200 Subject: [PATCH 003/312] Conceived parameterized parsers: implements io-here. --- sh.peg.scm | 34 +++++++++++++++++++++++++--------- test.sh | 4 ++++ 2 files changed, 29 insertions(+), 9 deletions(-) diff --git a/sh.peg.scm b/sh.peg.scm index e457cdb..f86ba70 100644 --- a/sh.peg.scm +++ b/sh.peg.scm @@ -37,8 +37,24 @@ (apply system* cmd) )) -;; insert / error at convenient location to short circuit backtracking + (define (parse input) + + (define label "") + (define (label-name str len pos) + (let ((at (string-skip str char-alphabetic? pos len))) + (set! label (substring str pos at)) + (if (< at len) (list at '()) + #f))) + + (define (label-match str len pos) + (if (string-prefix? label (substring str pos)) (list (+ pos (string-length label)) '()) + #f)) + + (define-peg-pattern here-label none label-name) + (define-peg-pattern here-delim none label-match) + (define-peg-pattern here-document all (and (+ (and (not-followed-by here-delim) peg-any)) here-delim)) + (define-peg-string-patterns "script <-- (sp / linebreak)* (term (separator term)* separator?)? term <-- pipeline (sp* (and / or) (sp / linebreak)* pipeline)* @@ -63,14 +79,13 @@ function-body <-- compound-command io-redirect* brace-group <-- '{' sp* compound-list sp* '}' simple-command <-- (io-redirect sp+)* !reserved word (sp+ (io-redirect / (!reserved word)))* - xsimple-command <-- !reserved ((cmd-prefix (sp+ cmd-suffix)?) / (word (sp+ cmd-suffix)?)) reserved < ('if' / 'then' / 'else' / 'elif' / 'fi' / 'for' / 'done' / 'do' / 'until' / 'while') (sp / linebreak) - cmd-prefix <-- (io-redirect (sp* io-redirect)*) / (word (sp+ word)*) - cmd-suffix <-- (io-redirect (sp* io-redirect)*) / (word (sp+ word)*) io-redirect <-- [0-9]* sp* (io-here / io-file) io-file <-- ('<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|') sp* ([0-9]+ / filename) + io-here <- ('<<' / '<<-') io-suffix here-document + io-op < '<<-' / '<<' / '<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|' + io-suffix <- sp* here-label sp* linebreak filename <-- word - io-here <-- ('<<' / '<<-') sp* word name <-- identifier identifier <-- [_a-zA-Z][_a-zA-Z0-9]* word <-- test / substitution / assignment / literal @@ -80,15 +95,16 @@ substitution <-- ('$' '(' script ')') / ('`' word (sp+ word)* '`') assignment <-- name assign word? assign < '=' - literal <- (subst / delim / (![0-9] (!sp !linebreak ![;&|$()=] .)+) / ([0-9]+ &separator)) literal* + literal <- (subst / delim / (![0-9] (!io-op !sp !linebreak !break !pipe !assign .)+) / ([0-9]+ &separator)) literal* subst <- '$' ('$' / '*' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) delim <- (['] (!['] .)* [']) / ([\"] (![\"] .)* [\"]) / ([`] (![`] .)* [`]) separator <-- (sp* break (sp / linebreak)*) / (sp / linebreak)+ break <-- '&' / ';' - sequential-sep <-- (semi (sp / linebreak)*) / (sp / linebreak)+ - semi < ';' - linebreak < [\r\n] + sequential-sep <-- (semi (sp / linebreak)*) / (sp / linebreak)+ + semi < ';' + linebreak < '\n' sp < [\t ]") + (let ((match (match-pattern script input))) (if (not (eq? (string-length input) (peg:end match))) (let ((tree (peg:tree match))) diff --git a/test.sh b/test.sh index c5d7d54..cb48edf 100644 --- a/test.sh +++ b/test.sh @@ -1,3 +1,7 @@ +cat < Date: Sun, 22 May 2016 16:07:40 +0200 Subject: [PATCH 004/312] Split grammar from main; add initial command line options. --- anguish | 80 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ sh.peg.scm | 45 ------------------------------ 2 files changed, 80 insertions(+), 45 deletions(-) create mode 100755 anguish diff --git a/anguish b/anguish new file mode 100755 index 0000000..6d9a641 --- /dev/null +++ b/anguish @@ -0,0 +1,80 @@ +#!/usr/bin/guile \ +-e main -s +!# + +(load "sh.peg.scm") + +(use-modules (ice-9 pretty-print)) +(use-modules (ice-9 getopt-long)) +(use-modules (ice-9 match)) +(use-modules (ice-9 rdelim)) + +(define (remove-shell-comments s) + (string-join (map + (lambda (s) + (let* ((n (string-index s #\#))) + (if n (string-pad-right s (string-length s) #\space 0 n) + s))) + (string-split s #\newline)) "\n")) + +(define (flatten lst) + (cond + ((null? lst) + '()) + ((list? (car lst)) + (append (flatten (car lst)) (flatten (cdr lst)))) + (else + (cons (car lst) (flatten (cdr lst)))))) + +(define (sh-exec ast) + (define (sh-exec- ast) + (match ast + (('name o) o) + (('word o) o) + (('command o ...) (map sh-exec- o)) + ((head tail ...) (map sh-exec- (append (list head) tail))) + ;;(('list o ...) (map sh-exec o)) + ((_ o) (sh-exec- o)) + (_ #f))) + (let ((cmd (filter identity (flatten (sh-exec- ast))))) + cmd + (apply system* cmd))) + + +(define (main args) + (let* ((option-spec '((help (single-char #\h) (value #f)) + (parse (single-char #\p) (value #f)) + (version (single-char #\v) (value #f)))) + (options (getopt-long args option-spec + #:stop-at-first-non-option #t )) + (help? (option-ref options 'help (null? (cdr args)))) + (parse? (option-ref options 'parse (null? #f))) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (if help? + (display "\ +anguish [options] + -h, --help Display this help + -p, --parse Parse the shell script and print the parse tree + -v, --version Display the version +") + (begin + (if version? + (display "\ + Copryright (c) 2016 Rutger E.W. van Beusekom + rutger.van.beusekom@gmail.com + + ANGUISH: ANother GUIle SHell + or + the feeling one might experience + when their shell lacks a programming language +" (current-output-port))) + (if (pair? files) + (let ((ast (parse + (remove-shell-comments + (read-string + (open-input-file + (car files))))))) + (if parse? + (pretty-print ast) + (sh-exec ast)))))))) diff --git a/sh.peg.scm b/sh.peg.scm index f86ba70..244aeb9 100644 --- a/sh.peg.scm +++ b/sh.peg.scm @@ -1,45 +1,8 @@ (use-modules (ice-9 peg)) (use-modules (ice-9 peg codegen)) (use-modules (ice-9 pretty-print)) -(use-modules (ice-9 rdelim)) -(use-modules (ice-9 match)) - - -(define (remove-shell-comments s) - (string-join (map - (lambda (s) - (let* ((n (string-index s #\#))) - (if n (string-pad-right s (string-length s) #\space 0 n) - s))) - (string-split s #\newline)) "\n")) - -(define (flatten lst) - (cond - ((null? lst) - '()) - ((list? (car lst)) - (append (flatten (car lst)) (flatten (cdr lst)))) - (else - (cons (car lst) (flatten (cdr lst)))))) - -(define (sh-exec ast) - (define (sh-exec- ast) - (match ast - (('name o) o) - (('word o) o) - (('command o ...) (map sh-exec- o)) - ((head tail ...) (map sh-exec- (append (list head) tail))) - ;;(('list o ...) (map sh-exec o)) - ((_ o) (sh-exec- o)) - (_ #f))) - (let ((cmd (filter identity (flatten (sh-exec- ast))))) - cmd - (apply system* cmd) - )) - (define (parse input) - (define label "") (define (label-name str len pos) (let ((at (string-skip str char-alphabetic? pos len))) @@ -112,11 +75,3 @@ (pretty-print "parse error" (current-error-port)) (pretty-print (peg:end match))) (peg:tree match)))) - - -;; (let* ((input (read-string (open-input-file (cadr (command-line))))) -;; (input (remove-shell-comments input)) -;; (ast (parse input))) -;; (sh-exec ast)) - -(pretty-print (parse (remove-shell-comments (read-string (open-input-file (cadr (command-line))))))) From d4854beb86000f1ad168d85ef611039b42ec9682 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sun, 22 May 2016 18:38:55 +0200 Subject: [PATCH 005/312] Add interactive mode. --- anguish | 131 ++++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 100 insertions(+), 31 deletions(-) diff --git a/anguish b/anguish index 6d9a641..3e14a64 100755 --- a/anguish +++ b/anguish @@ -4,10 +4,12 @@ (load "sh.peg.scm") -(use-modules (ice-9 pretty-print)) (use-modules (ice-9 getopt-long)) (use-modules (ice-9 match)) +(use-modules (ice-9 pretty-print)) (use-modules (ice-9 rdelim)) +(use-modules (ice-9 readline)) +(use-modules (ice-9 ftw)) (define (remove-shell-comments s) (string-join (map @@ -26,55 +28,122 @@ (else (cons (car lst) (flatten (cdr lst)))))) +(define (builtin cmd) + (if (and (pair? cmd) (string=? (car cmd) "cd")) + (lambda () (chdir (cadr cmd))) + #f)) + (define (sh-exec ast) (define (sh-exec- ast) (match ast (('name o) o) (('word o) o) - (('command o ...) (map sh-exec- o)) - ((head tail ...) (map sh-exec- (append (list head) tail))) - ;;(('list o ...) (map sh-exec o)) - ((_ o) (sh-exec- o)) + (('command o) (map sh-exec- o)) + ((head tail ...) (map sh-exec- tail)) + ((_ o) o) (_ #f))) (let ((cmd (filter identity (flatten (sh-exec- ast))))) - cmd - (apply system* cmd))) + (if (builtin cmd) + ((builtin cmd)) + (apply system* cmd)))) +(define (prompt) + (let* ((esc (string #\033)) + (CWD (getcwd)) + (HOME (getenv "HOME")) + (cwd (if (string-prefix? HOME CWD) + (string-replace CWD "~" 0 (string-length HOME)) + CWD))) + (string-append esc "[01;34m" cwd esc "[00m$ "))) + +(define (redraw-current-line) + (dynamic-call (dynamic-func "rl_refresh_line" + (dynamic-link "libreadline.so")) + #f)) + +(define (filename-completion text state) + (if (not state) + (let ((completions (map car + (filter (lambda (entry) (string-prefix? text (car entry))) + (cddr (file-system-tree (getcwd))))))) + (cond ((< 1 (length completions)) (begin (newline) + (display (string-join completions " ")) (newline) + (redraw-current-line) + #f)) + ((= 1 (length completions)) (car completions)) + (#t #f))) + #f)) + +(define (search-binary-in-path-completion text state) + (if (not state) + (let ((completions (map car + (filter (lambda (entry) (string-prefix? text (car entry))) + (cddr (file-system-tree "/bin")))))) + (cond ((< 1 (length completions)) (begin (newline) + (display (string-join completions " ")) (newline) + (redraw-current-line) + #f)) + ((= 1 (length completions)) (car completions)) + (#t #f))) + #f)) + +(define (completion text state) + (or (filename-completion text state) + ;(search-binary-in-path-completion text state) + )) (define (main args) (let* ((option-spec '((help (single-char #\h) (value #f)) (parse (single-char #\p) (value #f)) (version (single-char #\v) (value #f)))) (options (getopt-long args option-spec - #:stop-at-first-non-option #t )) - (help? (option-ref options 'help (null? (cdr args)))) + #:stop-at-first-non-option #t )) + (help? (option-ref options 'help #f)) (parse? (option-ref options 'parse (null? #f))) (version? (option-ref options 'version #f)) (files (option-ref options '() '()))) - (if help? - (display "\ + (cond + (help? + (display "\ anguish [options] -h, --help Display this help -p, --parse Parse the shell script and print the parse tree -v, --version Display the version -") - (begin - (if version? - (display "\ - Copryright (c) 2016 Rutger E.W. van Beusekom - rutger.van.beusekom@gmail.com +")) + (version? + (display " +Anguish 0.1 +Copryright (C) 2016 R.E.W. van Beusekom, rutger.van.beusekom@gmail.com. - ANGUISH: ANother GUIle SHell - or - the feeling one might experience - when their shell lacks a programming language -" (current-output-port))) - (if (pair? files) - (let ((ast (parse - (remove-shell-comments - (read-string - (open-input-file - (car files))))))) - (if parse? - (pretty-print ast) - (sh-exec ast)))))))) +This is anguish, ANother GUIle SHell, or the feeling you might have +when your shell lacks a real programming language. Anguish is free +software and is covered by the GNU Public License, see COPYING for the +copyleft. +")) + ((pair? files) + (let ((ast (parse + (remove-shell-comments + (read-string + (open-input-file + (car files))))))) + (if parse? + (pretty-print ast) + (sh-exec ast)))) + (#t (let* ((HOME (string-append (getenv "HOME") "/.anguishistory")) + (thunk (lambda () + (let loop ((line (readline (prompt)))) + (if (not (eof-object? line)) + (begin + (let ((ast (parse (remove-shell-comments line)))) + (add-history line) + (if parse? + (pretty-print ast) + (sh-exec ast))) + (loop (readline (prompt))))))))) + (activate-readline) + (clear-history) + (read-history HOME) + (with-readline-completion-function completion thunk) + ;;(thunk) + (write-history HOME)) + (newline))))) From de319e38eb4efc9a4cfd7783bea2c0a69664f81b Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Tue, 31 May 2016 00:13:04 +0200 Subject: [PATCH 006/312] Add pipeline support. --- anguish | 51 ++++++++++++++++++++++++--------------------------- pipe.scm | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 77 insertions(+), 27 deletions(-) create mode 100644 pipe.scm diff --git a/anguish b/anguish index 3e14a64..aa1d464 100755 --- a/anguish +++ b/anguish @@ -3,6 +3,7 @@ !# (load "sh.peg.scm") +(load "pipe.scm") (use-modules (ice-9 getopt-long)) (use-modules (ice-9 match)) @@ -19,33 +20,30 @@ s))) (string-split s #\newline)) "\n")) -(define (flatten lst) - (cond - ((null? lst) - '()) - ((list? (car lst)) - (append (flatten (car lst)) (flatten (cdr lst)))) - (else - (cons (car lst) (flatten (cdr lst)))))) - (define (builtin cmd) - (if (and (pair? cmd) (string=? (car cmd) "cd")) + (if (and (pair? cmd) (string? (car cmd)) (string=? (car cmd) "cd")) (lambda () (chdir (cadr cmd))) #f)) +(define (transform ast) + (match ast + (('pipeline command) (transform command)) + (('pipeline command piped-commands) (cons 'pipeline (cons (transform command) (transform piped-commands)))) + (('simple-command ('word s)) (list s)) + (('simple-command ('word s1) ('word s2)) (list s1 s2)) + (('simple-command ('word s1) (list ('word s2) ...)) (cons s1 s2)) + ((('pipe _) command ...) (map transform command)) + (((('pipe _) command) ...) (map transform command)) + ((_ o) (transform o)) + (_ ast))) + (define (sh-exec ast) - (define (sh-exec- ast) - (match ast - (('name o) o) - (('word o) o) - (('command o) (map sh-exec- o)) - ((head tail ...) (map sh-exec- tail)) - ((_ o) o) - (_ #f))) - (let ((cmd (filter identity (flatten (sh-exec- ast))))) + (let ((cmd (transform ast))) (if (builtin cmd) ((builtin cmd)) - (apply system* cmd)))) + (if (and (pair? cmd) (eq? 'pipeline (car cmd))) + (pipeline (cdr cmd)) + (apply system* cmd))))) (define (prompt) (let* ((esc (string #\033)) @@ -101,7 +99,10 @@ (help? (option-ref options 'help #f)) (parse? (option-ref options 'parse (null? #f))) (version? (option-ref options 'version #f)) - (files (option-ref options '() '()))) + (files (option-ref options '() '())) + (run (lambda (ast) (if parse? + (pretty-print (list ast (transform ast))) + (sh-exec ast))))) (cond (help? (display "\ @@ -126,9 +127,7 @@ copyleft. (read-string (open-input-file (car files))))))) - (if parse? - (pretty-print ast) - (sh-exec ast)))) + (run ast))) (#t (let* ((HOME (string-append (getenv "HOME") "/.anguishistory")) (thunk (lambda () (let loop ((line (readline (prompt)))) @@ -136,9 +135,7 @@ copyleft. (begin (let ((ast (parse (remove-shell-comments line)))) (add-history line) - (if parse? - (pretty-print ast) - (sh-exec ast))) + (run ast)) (loop (readline (prompt))))))))) (activate-readline) (clear-history) diff --git a/pipe.scm b/pipe.scm new file mode 100644 index 0000000..7aabe17 --- /dev/null +++ b/pipe.scm @@ -0,0 +1,53 @@ +(use-modules (ice-9 popen)) +(use-modules (srfi srfi-8)) ;; receive + +(define (pipe*) + (let ((p (pipe))) + (values (car p) (cdr p)))) + +;; lhs rhs +;; [source] w -> r [filter] w -> r [sink] + +(define (exec* command) + (apply execlp (cons (car command) command))) + +(define (spawn-source command) + (receive (r w) (pipe*) + (let ((pid (primitive-fork))) + (cond ((= 0 pid) (close r) + (move->fdes w 1) + (exec* command)) + (#t + (close w) + r))))) + +(define (spawn-filter src command) + (receive (r w) (pipe*) + (let ((pid (primitive-fork))) + (cond ((= 0 pid) + (move->fdes src 0) + (close r) + (move->fdes w 1) + (exec* command)) + (#t + (close w) + r))))) + +(define (spawn-sink src command) + (let ((pid (primitive-fork))) + (cond ((= 0 pid) + (move->fdes src 0) + (exec* command)) + (#t + (close src) + (waitpid pid))))) + +(define (pipeline commands) + (if (< 1 (length commands)) + (let loop ((src (spawn-source (car commands))) + (commands (cdr commands))) + (if (null? (cdr commands)) (spawn-sink src (car commands)) + (loop (spawn-filter src (car commands)) + (cdr commands)))))) + +;;(pipeline (list (list "ls" "/") (list "grep" "o") (list "tr" "o" "e"))) From 340917ce4cc5d2235443a145a8b2611eb5b83038 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Tue, 7 Jun 2016 00:54:23 +0200 Subject: [PATCH 007/312] Modularized anguish. --- anguish | 148 ++------------------------------------- sh/anguish.scm | 146 ++++++++++++++++++++++++++++++++++++++ sh.peg.scm => sh/peg.scm | 10 +-- pipe.scm => sh/pipe.scm | 6 +- 4 files changed, 163 insertions(+), 147 deletions(-) create mode 100644 sh/anguish.scm rename sh.peg.scm => sh/peg.scm (95%) rename pipe.scm => sh/pipe.scm (92%) diff --git a/anguish b/anguish index aa1d464..236e969 100755 --- a/anguish +++ b/anguish @@ -1,146 +1,12 @@ #!/usr/bin/guile \ -e main -s !# - -(load "sh.peg.scm") -(load "pipe.scm") - -(use-modules (ice-9 getopt-long)) -(use-modules (ice-9 match)) -(use-modules (ice-9 pretty-print)) -(use-modules (ice-9 rdelim)) -(use-modules (ice-9 readline)) -(use-modules (ice-9 ftw)) - -(define (remove-shell-comments s) - (string-join (map - (lambda (s) - (let* ((n (string-index s #\#))) - (if n (string-pad-right s (string-length s) #\space 0 n) - s))) - (string-split s #\newline)) "\n")) - -(define (builtin cmd) - (if (and (pair? cmd) (string? (car cmd)) (string=? (car cmd) "cd")) - (lambda () (chdir (cadr cmd))) - #f)) - -(define (transform ast) - (match ast - (('pipeline command) (transform command)) - (('pipeline command piped-commands) (cons 'pipeline (cons (transform command) (transform piped-commands)))) - (('simple-command ('word s)) (list s)) - (('simple-command ('word s1) ('word s2)) (list s1 s2)) - (('simple-command ('word s1) (list ('word s2) ...)) (cons s1 s2)) - ((('pipe _) command ...) (map transform command)) - (((('pipe _) command) ...) (map transform command)) - ((_ o) (transform o)) - (_ ast))) - -(define (sh-exec ast) - (let ((cmd (transform ast))) - (if (builtin cmd) - ((builtin cmd)) - (if (and (pair? cmd) (eq? 'pipeline (car cmd))) - (pipeline (cdr cmd)) - (apply system* cmd))))) - -(define (prompt) - (let* ((esc (string #\033)) - (CWD (getcwd)) - (HOME (getenv "HOME")) - (cwd (if (string-prefix? HOME CWD) - (string-replace CWD "~" 0 (string-length HOME)) - CWD))) - (string-append esc "[01;34m" cwd esc "[00m$ "))) - -(define (redraw-current-line) - (dynamic-call (dynamic-func "rl_refresh_line" - (dynamic-link "libreadline.so")) - #f)) - -(define (filename-completion text state) - (if (not state) - (let ((completions (map car - (filter (lambda (entry) (string-prefix? text (car entry))) - (cddr (file-system-tree (getcwd))))))) - (cond ((< 1 (length completions)) (begin (newline) - (display (string-join completions " ")) (newline) - (redraw-current-line) - #f)) - ((= 1 (length completions)) (car completions)) - (#t #f))) - #f)) - -(define (search-binary-in-path-completion text state) - (if (not state) - (let ((completions (map car - (filter (lambda (entry) (string-prefix? text (car entry))) - (cddr (file-system-tree "/bin")))))) - (cond ((< 1 (length completions)) (begin (newline) - (display (string-join completions " ")) (newline) - (redraw-current-line) - #f)) - ((= 1 (length completions)) (car completions)) - (#t #f))) - #f)) - -(define (completion text state) - (or (filename-completion text state) - ;(search-binary-in-path-completion text state) - )) +;; workaround: +;; -e (@ (sh anguish) main) -s +;; leads to: +;; ERROR: In procedure read: +;; ERROR: In procedure scm_i_lreadparen: #:1:3: end of file (define (main args) - (let* ((option-spec '((help (single-char #\h) (value #f)) - (parse (single-char #\p) (value #f)) - (version (single-char #\v) (value #f)))) - (options (getopt-long args option-spec - #:stop-at-first-non-option #t )) - (help? (option-ref options 'help #f)) - (parse? (option-ref options 'parse (null? #f))) - (version? (option-ref options 'version #f)) - (files (option-ref options '() '())) - (run (lambda (ast) (if parse? - (pretty-print (list ast (transform ast))) - (sh-exec ast))))) - (cond - (help? - (display "\ -anguish [options] - -h, --help Display this help - -p, --parse Parse the shell script and print the parse tree - -v, --version Display the version -")) - (version? - (display " -Anguish 0.1 -Copryright (C) 2016 R.E.W. van Beusekom, rutger.van.beusekom@gmail.com. - -This is anguish, ANother GUIle SHell, or the feeling you might have -when your shell lacks a real programming language. Anguish is free -software and is covered by the GNU Public License, see COPYING for the -copyleft. -")) - ((pair? files) - (let ((ast (parse - (remove-shell-comments - (read-string - (open-input-file - (car files))))))) - (run ast))) - (#t (let* ((HOME (string-append (getenv "HOME") "/.anguishistory")) - (thunk (lambda () - (let loop ((line (readline (prompt)))) - (if (not (eof-object? line)) - (begin - (let ((ast (parse (remove-shell-comments line)))) - (add-history line) - (run ast)) - (loop (readline (prompt))))))))) - (activate-readline) - (clear-history) - (read-history HOME) - (with-readline-completion-function completion thunk) - ;;(thunk) - (write-history HOME)) - (newline))))) + (set! %load-path (cons (dirname (car args)) %load-path)) + ((@ (sh anguish) main) args)) diff --git a/sh/anguish.scm b/sh/anguish.scm new file mode 100644 index 0000000..001d172 --- /dev/null +++ b/sh/anguish.scm @@ -0,0 +1,146 @@ +(define-module (sh anguish) + :use-module (ice-9 getopt-long) + :use-module (ice-9 match) + :use-module (ice-9 pretty-print) + :use-module (ice-9 rdelim) + :use-module (ice-9 readline) + :use-module (ice-9 ftw) + + :export (main)) + +(use-modules ((sh pipe) :renamer (symbol-prefix-proc 'sh:))) +(use-modules ((sh peg) :renamer (symbol-prefix-proc 'sh:))) + +(define (main args) + (let* ((option-spec '((help (single-char #\h) (value #f)) + (parse (single-char #\p) (value #f)) + (version (single-char #\v) (value #f)))) + (options (getopt-long args option-spec + #:stop-at-first-non-option #t )) + (help? (option-ref options 'help #f)) + (parse? (option-ref options 'parse (null? #f))) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '())) + (run (lambda (ast) (if parse? + (pretty-print (list ast (transform ast))) + (sh-exec ast))))) + (cond + (help? + (display "\ +anguish [options] + -h, --help Display this help + -p, --parse Parse the shell script and print the parse tree + -v, --version Display the version +")) + (version? + (display " +Anguish 0.1 +Copryright (C) 2016 R.E.W. van Beusekom, rutger.van.beusekom@gmail.com. + +This is anguish, ANother GUIle SHell, or the feeling you might have +when your shell lacks a real programming language. Anguish is free +software and is covered by the GNU Public License, see COPYING for the +copyleft. +")) + ((pair? files) + (let ((ast (sh:parse + (remove-shell-comments + (read-string + (open-input-file + (car files))))))) + (run ast))) + (#t (let* ((HOME (string-append (getenv "HOME") "/.anguishistory")) + (thunk (lambda () + (let loop ((line (readline (prompt)))) + (if (not (eof-object? line)) + (begin + (let ((ast (sh:parse (remove-shell-comments line)))) + (add-history line) + (run ast)) + (loop (readline (prompt))))))))) + (activate-readline) + (clear-history) + (read-history HOME) + (with-readline-completion-function completion thunk) + ;;(thunk) + (write-history HOME)) + (newline))))) + + +(define (remove-shell-comments s) + (string-join (map + (lambda (s) + (let* ((n (string-index s #\#))) + (if n (string-pad-right s (string-length s) #\space 0 n) + s))) + (string-split s #\newline)) "\n")) + +(define (builtin cmd) + (if (and (pair? cmd) (string? (car cmd)) (string=? (car cmd) "cd")) + (lambda () (chdir (cadr cmd))) + #f)) + +(define (transform ast) + (match ast + (('pipeline command) (transform command)) + (('pipeline command piped-commands) (cons 'pipeline (cons (transform command) (transform piped-commands)))) + (('simple-command ('word s)) (list s)) + (('simple-command ('word s1) ('word s2)) (list s1 s2)) + (('simple-command ('word s1) (list ('word s2) ...)) (cons s1 s2)) + ((('pipe _) command ...) (map transform command)) + (((('pipe _) command) ...) (map transform command)) + ((_ o) (transform o)) + (_ ast))) + +(define (sh-exec ast) + (let ((cmd (transform ast))) + (if (builtin cmd) + ((builtin cmd)) + (if (and (pair? cmd) (eq? 'pipeline (car cmd))) + (sh:pipeline (cdr cmd)) + (apply system* cmd))))) + +(define (prompt) + (let* ((esc (string #\033)) + (CWD (getcwd)) + (HOME (getenv "HOME")) + (cwd (if (string-prefix? HOME CWD) + (string-replace CWD "~" 0 (string-length HOME)) + CWD))) + (string-append esc "[01;34m" cwd esc "[00m$ "))) + +(define (redraw-current-line) + (dynamic-call (dynamic-func "rl_refresh_line" + (dynamic-link "libreadline.so")) + #f)) + +(define (filename-completion text state) + (if (not state) + (let ((completions (map car + (filter (lambda (entry) (string-prefix? text (car entry))) + (cddr (file-system-tree (getcwd))))))) + (cond ((< 1 (length completions)) (begin (newline) + (display (string-join completions " ")) (newline) + (redraw-current-line) + #f)) + ((= 1 (length completions)) (car completions)) + (#t #f))) + #f)) + +(define (search-binary-in-path-completion text state) + (if (not state) + (let ((completions (map car + (filter (lambda (entry) (string-prefix? text (car entry))) + (cddr (file-system-tree "/bin")))))) + (cond ((< 1 (length completions)) (begin (newline) + (display (string-join completions " ")) (newline) + (redraw-current-line) + #f)) + ((= 1 (length completions)) (car completions)) + (#t #f))) + #f)) + +(define (completion text state) + (or (filename-completion text state) + ;(search-binary-in-path-completion text state) + )) diff --git a/sh.peg.scm b/sh/peg.scm similarity index 95% rename from sh.peg.scm rename to sh/peg.scm index 244aeb9..f94208d 100644 --- a/sh.peg.scm +++ b/sh/peg.scm @@ -1,6 +1,8 @@ -(use-modules (ice-9 peg)) -(use-modules (ice-9 peg codegen)) -(use-modules (ice-9 pretty-print)) +(define-module (sh peg) + :use-module (ice-9 peg) + :use-module (ice-9 peg codegen) + :use-module (ice-9 pretty-print) + :export (parse)) (define (parse input) (define label "") @@ -50,7 +52,7 @@ io-suffix <- sp* here-label sp* linebreak filename <-- word name <-- identifier - identifier <-- [_a-zA-Z][_a-zA-Z0-9]* + identifier <- [_a-zA-Z][_a-zA-Z0-9]* word <-- test / substitution / assignment / literal test <-- ltest (!' ]' .)* rtest ltest < '[ ' diff --git a/pipe.scm b/sh/pipe.scm similarity index 92% rename from pipe.scm rename to sh/pipe.scm index 7aabe17..c38350f 100644 --- a/pipe.scm +++ b/sh/pipe.scm @@ -1,5 +1,7 @@ -(use-modules (ice-9 popen)) -(use-modules (srfi srfi-8)) ;; receive +(define-module (sh pipe) + :use-module (ice-9 popen) + :use-module (srfi srfi-8) + :export (pipeline)) (define (pipe*) (let ((p (pipe))) From 87a682e0f45f627bb1e30a38bcfd9dc630d34b6d Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sat, 17 Sep 2016 19:29:57 +0200 Subject: [PATCH 008/312] WIP --- README | 35 +++++++++++++++++++++++++++++------ 1 file changed, 29 insertions(+), 6 deletions(-) diff --git a/README b/README index ee9944a..af48962 100644 --- a/README +++ b/README @@ -1,7 +1,30 @@ -ANGUISH that which one might experience when their shell lacks a programming language -or -ANother GUIle SHell +ANGUISH: that which you might experience when your shell +falls short of expressing your programming solution -This project aims to produce at least a POSIX compliant sh -replacement. On top of that it also intends to make scheme available -for interactive and scripting application. +or + +AN[other] GUIle SHell +Anguish is Not a GUIle SHell + +This project aims to produce at least a POSIX compliant sh replacement +or even implement GNU bash. On top of that it also intends to make +scheme available for interactive and scripting application. The +approach also intends to allow capturing the intermediate scheme +representation of the "original" shell script to offer a migration +path away from [ba]sh. On top of this GNU make could similarly be +replaced, as make turns out to be fraught with limitations and +complexities. One of the features I personally desire is not be +forced to keep doing what was done in the past, i.e. once an object +file is produced, it does not have to be produced again as long as the +original is kept around. The orignal must be replaced when any of its +dependencies change (source, compiler options, linker, etc.) + +I feel that the shell has been instrumental on my path to embracing +functional programming, however now I mostly experience that the +language itselfs folds on functional expression, pun intended. + + + + +* history flattened vs full, i.e. navigate interactively without + redundancy vs export as script From 38658f408d2413e890368acc8bfe31743b3b02de Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sat, 17 Sep 2016 19:30:17 +0200 Subject: [PATCH 009/312] HAX0R here --- anguish | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/anguish b/anguish index 236e969..488d4d1 100755 --- a/anguish +++ b/anguish @@ -1,4 +1,4 @@ -#!/usr/bin/guile \ +#!/usr/bin/guile-2.2 \ -e main -s !# ;; workaround: From 14147e01a3f3c7e2dd53b9b0b799ee3b0359fcbd Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sat, 17 Sep 2016 19:31:58 +0200 Subject: [PATCH 010/312] refactoring --- sh/anguish.scm | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 001d172..b88e130 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -11,6 +11,15 @@ (use-modules ((sh pipe) :renamer (symbol-prefix-proc 'sh:))) (use-modules ((sh peg) :renamer (symbol-prefix-proc 'sh:))) +(define (file-to-string filename) + ((compose read-string open-input-file) filename)) + +(define (string-to-ast string) + ((compose sh:parse remove-shell-comments) string)) + +(define (file-to-ast filename) + ((compose string-to-ast file-to-string) filename)) + (define (main args) (let* ((option-spec '((help (single-char #\h) (value #f)) (parse (single-char #\p) (value #f)) @@ -22,7 +31,9 @@ (version? (option-ref options 'version #f)) (files (option-ref options '() '())) (run (lambda (ast) (if parse? - (pretty-print (list ast (transform ast))) + (let ((ast- (transform ast))) + (display ast) (newline)(newline) + (display ast-) (newline)(newline)) (sh-exec ast))))) (cond (help? @@ -43,18 +54,14 @@ software and is covered by the GNU Public License, see COPYING for the copyleft. ")) ((pair? files) - (let ((ast (sh:parse - (remove-shell-comments - (read-string - (open-input-file - (car files))))))) - (run ast))) + (let ((asts (map file-to-ast files))) + (map run asts))) (#t (let* ((HOME (string-append (getenv "HOME") "/.anguishistory")) (thunk (lambda () (let loop ((line (readline (prompt)))) (if (not (eof-object? line)) (begin - (let ((ast (sh:parse (remove-shell-comments line)))) + (let ((ast (string-to-ast line))) (add-history line) (run ast)) (loop (readline (prompt))))))))) @@ -81,7 +88,9 @@ copyleft. #f)) (define (transform ast) + ;(display 'TRANSFORM:) (display ast) (newline) (match ast + (('script command 'separator) (transform command)) (('pipeline command) (transform command)) (('pipeline command piped-commands) (cons 'pipeline (cons (transform command) (transform piped-commands)))) (('simple-command ('word s)) (list s)) From 4995a36773d99a47a6bc9a478b562d40cffae56c Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sat, 17 Sep 2016 19:36:09 +0200 Subject: [PATCH 011/312] various fixes, TODO remove debugging code --- sh/peg.scm | 48 ++++++++++++++++++++++++++++-------------------- 1 file changed, 28 insertions(+), 20 deletions(-) diff --git a/sh/peg.scm b/sh/peg.scm index f94208d..fe0768a 100644 --- a/sh/peg.scm +++ b/sh/peg.scm @@ -21,54 +21,56 @@ (define-peg-pattern here-document all (and (+ (and (not-followed-by here-delim) peg-any)) here-delim)) (define-peg-string-patterns -"script <-- (sp / linebreak)* (term (separator term)* separator?)? - term <-- pipeline (sp* (and / or) (sp / linebreak)* pipeline)* +"script <-- ws* (term (separator term)* separator?)? + term <-- pipeline (sp* (and / or) ws* pipeline)* and <-- '&&' or <-- '||' - pipeline <-- '!'? sp* command (sp* pipe (sp / linebreak)* command)* + pipeline <-- '!'? sp* command (sp* pipe ws* command)* pipe <-- '|' command <-- simple-command / (compound-command (sp+ io-redirect)*) / function-def compound-command <-- brace-group / subshell / for-clause / case-clause / if-clause / while-clause / until-clause - subshell <-- '(' sp* compound-list sp* ')' - compound-list <-- (sp / linebreak)* term (separator term)* separator? - case-clause <-- 'case' sp+ word (sp / linebreak)* 'in' (sp / linebreak)* (case-item sp)* 'esac' - case-item <-- '('? sp* pattern sp* ')' (((sp / linebreak) ';;' (sp / linebreak)) / ((compound-list sp* ';;'?)? (sp / linebreak))) + subshell <-- '(' compound-list ')' + compound-list <-- ws* term (separator term)* separator? + case-clause <-- 'case' sp+ word ws* 'in' ws* (case-item sp)* 'esac' + case-item <-- '('? sp* pattern sp* ')' ((ws ';;' ws) / ((compound-list sp* ';;'?)? ws)) pattern <-- word (sp* '|' sp* word)* - for-clause <-- 'for' sp+ identifier (sp / linebreak)+ ('in' (sp+ word)* sp* sequential-sep)? do-group + for-clause <-- 'for' sp+ identifier ws+ ('in' (sp+ word)* sp* sequential-sep)? do-group do-group <-- 'do' compound-list 'done' if-clause <-- 'if' compound-list 'then' compound-list else-part? 'fi' else-part <-- ('elif' compound-list 'then' compound-list else-part?) / ('else' compound-list) while-clause <-- 'while' compound-list do-group until-clause <-- 'until' compound-list do-group - function-def <-- name sp* '(' sp* ')' (sp / linebreak)* function-body + function-def <-- name sp* '(' sp* ')' ws* function-body function-body <-- compound-command io-redirect* brace-group <-- '{' sp* compound-list sp* '}' - simple-command <-- (io-redirect sp+)* !reserved word (sp+ (io-redirect / (!reserved word)))* - reserved < ('if' / 'then' / 'else' / 'elif' / 'fi' / 'for' / 'done' / 'do' / 'until' / 'while') (sp / linebreak) + simple-command <-- (io-redirect sp+)* (!(reserved ws+) word) (sp+ (io-redirect / (!(reserved ws+) word)))* + reserved < ('case' / 'esac' / 'if' / 'fi' / 'then' / 'else' / 'elif' / 'for' / 'done' / 'do' / 'until' / 'while') io-redirect <-- [0-9]* sp* (io-here / io-file) io-file <-- ('<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|') sp* ([0-9]+ / filename) io-here <- ('<<' / '<<-') io-suffix here-document io-op < '<<-' / '<<' / '<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|' - io-suffix <- sp* here-label sp* linebreak + io-suffix <- sp* here-label sp* nl filename <-- word name <-- identifier identifier <- [_a-zA-Z][_a-zA-Z0-9]* word <-- test / substitution / assignment / literal - test <-- ltest (!' ]' .)* rtest + test <-- ltest (!rtest .)* rtest ltest < '[ ' rtest < ' ]' - substitution <-- ('$' '(' script ')') / ('`' word (sp+ word)* '`') + substitution <-- ('$(' 'ls' ')') / ('`' script '`') assignment <-- name assign word? assign < '=' - literal <- (subst / delim / (![0-9] (!io-op !sp !linebreak !break !pipe !assign .)+) / ([0-9]+ &separator)) literal* - subst <- '$' ('$' / '*' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) + literal <-- (subst / delim / (![0-9] (![()] !io-op !sp !nl !break !pipe !assign .)+) / ([0-9]+ &separator)) literal* + subst <-- '$' ('$' / '*' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) delim <- (['] (!['] .)* [']) / ([\"] (![\"] .)* [\"]) / ([`] (![`] .)* [`]) - separator <-- (sp* break (sp / linebreak)*) / (sp / linebreak)+ + separator <-- (sp* break ws*) / ws* break <-- '&' / ';' - sequential-sep <-- (semi (sp / linebreak)*) / (sp / linebreak)+ + sequential-sep <-- (semi ws*) / ws+ semi < ';' - linebreak < '\n' - sp < [\t ]") + nl < '\n' + sp < [\t ] + ws < sp / nl +") (let ((match (match-pattern script input))) (if (not (eq? (string-length input) (peg:end match))) @@ -77,3 +79,9 @@ (pretty-print "parse error" (current-error-port)) (pretty-print (peg:end match))) (peg:tree match)))) + + +;; (display 'foo) +;; (newline) +;; (display (parse "for f in a b; do echo $f; ls; done")) +;; (newline) From 979572299222cbb2583fef979721ee966789a731 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sat, 17 Sep 2016 21:30:34 +0200 Subject: [PATCH 012/312] exit status --- sh/anguish.scm | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index b88e130..eb0416d 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -1,4 +1,5 @@ (define-module (sh anguish) + :use-module (srfi srfi-1) :use-module (ice-9 getopt-long) :use-module (ice-9 match) :use-module (ice-9 pretty-print) @@ -30,11 +31,15 @@ (parse? (option-ref options 'parse (null? #f))) (version? (option-ref options 'version #f)) (files (option-ref options '() '())) - (run (lambda (ast) (if parse? - (let ((ast- (transform ast))) - (display ast) (newline)(newline) - (display ast-) (newline)(newline)) - (sh-exec ast))))) + (run (lambda (ast) (and ast + (cond (parse? + (let ((ast- (transform ast))) + (display ast) (newline)(newline) + (display ast-) (newline)(newline) + #t)) + (#t + (sh-exec ast) + #t)))))) (cond (help? (display "\ @@ -54,8 +59,9 @@ software and is covered by the GNU Public License, see COPYING for the copyleft. ")) ((pair? files) - (let ((asts (map file-to-ast files))) - (map run asts))) + (let* ((asts (map file-to-ast files)) + (status (map run asts))) + (quit (every identity status)))) (#t (let* ((HOME (string-append (getenv "HOME") "/.anguishistory")) (thunk (lambda () (let loop ((line (readline (prompt)))) From cb204e16c0ad362932988a1426ce69ddfd9ececa Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sat, 17 Sep 2016 21:30:58 +0200 Subject: [PATCH 013/312] case support --- sh/peg.scm | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/sh/peg.scm b/sh/peg.scm index fe0768a..51839cb 100644 --- a/sh/peg.scm +++ b/sh/peg.scm @@ -31,8 +31,9 @@ compound-command <-- brace-group / subshell / for-clause / case-clause / if-clause / while-clause / until-clause subshell <-- '(' compound-list ')' compound-list <-- ws* term (separator term)* separator? - case-clause <-- 'case' sp+ word ws* 'in' ws* (case-item sp)* 'esac' - case-item <-- '('? sp* pattern sp* ')' ((ws ';;' ws) / ((compound-list sp* ';;'?)? ws)) + case-clause <-- 'case' sp+ word ws+ 'in' ws+ case-item* 'esac' + case-item <-- sp* pattern sp* ')' compound-list? ws* case-sep ws + case-sep < ';;' pattern <-- word (sp* '|' sp* word)* for-clause <-- 'for' sp+ identifier ws+ ('in' (sp+ word)* sp* sequential-sep)? do-group do-group <-- 'do' compound-list 'done' @@ -53,7 +54,8 @@ filename <-- word name <-- identifier identifier <- [_a-zA-Z][_a-zA-Z0-9]* - word <-- test / substitution / assignment / literal + word <-- test / substitution / assignment / literal / number + number <-- [0-9]+ test <-- ltest (!rtest .)* rtest ltest < '[ ' rtest < ' ]' @@ -63,9 +65,10 @@ literal <-- (subst / delim / (![0-9] (![()] !io-op !sp !nl !break !pipe !assign .)+) / ([0-9]+ &separator)) literal* subst <-- '$' ('$' / '*' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) delim <- (['] (!['] .)* [']) / ([\"] (![\"] .)* [\"]) / ([`] (![`] .)* [`]) - separator <-- (sp* break ws*) / ws* - break <-- '&' / ';' + separator <-- (sp* break !semi ws*) / ws* + break <-- amp / semi sequential-sep <-- (semi ws*) / ws+ + amp < '&' semi < ';' nl < '\n' sp < [\t ] @@ -77,7 +80,8 @@ (let ((tree (peg:tree match))) (pretty-print (peg:tree match)) (pretty-print "parse error" (current-error-port)) - (pretty-print (peg:end match))) + (pretty-print (peg:end match)) + #f) (peg:tree match)))) From fcfabb096d59caa30e254bbaba938ccf3ef9c76b Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sat, 17 Sep 2016 21:31:36 +0200 Subject: [PATCH 014/312] tests --- test/case | 4 ++++ test/for | 1 + test/ifthen | 1 + test/iohere | 3 +++ test/ls | 1 + test/pipe | 1 + test/substitution | 1 + test/test | 1 + 8 files changed, 13 insertions(+) create mode 100644 test/case create mode 100644 test/for create mode 100644 test/ifthen create mode 100644 test/iohere create mode 100644 test/ls create mode 100644 test/pipe create mode 100644 test/substitution create mode 100644 test/test diff --git a/test/case b/test/case new file mode 100644 index 0000000..0cfeb5a --- /dev/null +++ b/test/case @@ -0,0 +1,4 @@ +case "$1" in + 1) echo foo;; + *) echo bar;; +esac diff --git a/test/for b/test/for new file mode 100644 index 0000000..72e0d88 --- /dev/null +++ b/test/for @@ -0,0 +1 @@ +for f in *; do echo $f | grep c; done diff --git a/test/ifthen b/test/ifthen new file mode 100644 index 0000000..2c1e983 --- /dev/null +++ b/test/ifthen @@ -0,0 +1 @@ +if ls * | grep foo; then echo ok; fi diff --git a/test/iohere b/test/iohere new file mode 100644 index 0000000..15ff922 --- /dev/null +++ b/test/iohere @@ -0,0 +1,3 @@ +cat < Date: Mon, 19 Sep 2016 12:37:38 +0200 Subject: [PATCH 015/312] fix transform --- sh/anguish.scm | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index eb0416d..95873f5 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -22,7 +22,8 @@ ((compose string-to-ast file-to-string) filename)) (define (main args) - (let* ((option-spec '((help (single-char #\h) (value #f)) + (let* ((option-spec '((debug (single-char #\d) (value #f)) + (help (single-char #\h) (value #f)) (parse (single-char #\p) (value #f)) (version (single-char #\v) (value #f)))) (options (getopt-long args option-spec @@ -34,8 +35,8 @@ (run (lambda (ast) (and ast (cond (parse? (let ((ast- (transform ast))) - (display ast) (newline)(newline) - (display ast-) (newline)(newline) + (display "parsed : ") (display ast) (newline)(newline) + (display "prepared: ") (display ast-) (newline)(newline) #t)) (#t (sh-exec ast) @@ -94,14 +95,14 @@ copyleft. #f)) (define (transform ast) - ;(display 'TRANSFORM:) (display ast) (newline) (match ast (('script command 'separator) (transform command)) (('pipeline command) (transform command)) (('pipeline command piped-commands) (cons 'pipeline (cons (transform command) (transform piped-commands)))) - (('simple-command ('word s)) (list s)) - (('simple-command ('word s1) ('word s2)) (list s1 s2)) - (('simple-command ('word s1) (list ('word s2) ...)) (cons s1 s2)) + (('simple-command ('word s)) (list (transform s))) + (('simple-command ('word s1) ('word s2)) (list (transform s1) (transform s2))) + (('simple-command ('word s1) (('word s2) ...)) (cons (transform s1) (map transform s2))) + (('literal s) s) ((('pipe _) command ...) (map transform command)) (((('pipe _) command) ...) (map transform command)) ((_ o) (transform o)) @@ -109,6 +110,7 @@ copyleft. (define (sh-exec ast) (let ((cmd (transform ast))) + ;(display "executing: ")(display cmd) (newline) (if (builtin cmd) ((builtin cmd)) (if (and (pair? cmd) (eq? 'pipeline (car cmd))) From 8b1a499d748f735a9605099b8b0682861876ae2e Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Mon, 19 Sep 2016 22:07:46 +0200 Subject: [PATCH 016/312] nesting delimited --- sh/anguish.scm | 8 +++++++- sh/peg.scm | 8 +++++++- test/nesting | 1 + test/pipe | 2 +- test/substitution | 2 +- 5 files changed, 17 insertions(+), 4 deletions(-) create mode 100644 test/nesting diff --git a/sh/anguish.scm b/sh/anguish.scm index 95873f5..56a73af 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -102,7 +102,13 @@ copyleft. (('simple-command ('word s)) (list (transform s))) (('simple-command ('word s1) ('word s2)) (list (transform s1) (transform s2))) (('simple-command ('word s1) (('word s2) ...)) (cons (transform s1) (map transform s2))) - (('literal s) s) + (('literal s) (transform s)) + (('singlequotes s) (string-concatenate (list "'" s "'"))) + (('doublequotes s) (string-concatenate (list "\"" s "\""))) + (('backticks s) (string-concatenate (list "`" s "`"))) + (('delim ('singlequotes s ...)) (string-concatenate (map transform s))) + (('delim ('doublequotes s ...)) (string-concatenate (map transform s))) + (('delim ('backticks s ...)) (string-concatenate (map transform s))) ((('pipe _) command ...) (map transform command)) (((('pipe _) command) ...) (map transform command)) ((_ o) (transform o)) diff --git a/sh/peg.scm b/sh/peg.scm index 51839cb..1b519c4 100644 --- a/sh/peg.scm +++ b/sh/peg.scm @@ -64,7 +64,13 @@ assign < '=' literal <-- (subst / delim / (![0-9] (![()] !io-op !sp !nl !break !pipe !assign .)+) / ([0-9]+ &separator)) literal* subst <-- '$' ('$' / '*' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) - delim <- (['] (!['] .)* [']) / ([\"] (![\"] .)* [\"]) / ([`] (![`] .)* [`]) + delim <-- singlequotes / doublequotes / backticks + sq < ['] + dq < [\"] + bt < [`] + singlequotes <-- (sq (doublequotes / backticks / (!sq .))* sq) + doublequotes <-- (dq (singlequotes / backticks / (!dq .))* dq) + backticks <-- (bt (singlequotes / doublequotes / (!bt .))* bt) separator <-- (sp* break !semi ws*) / ws* break <-- amp / semi sequential-sep <-- (semi ws*) / ws+ diff --git a/test/nesting b/test/nesting new file mode 100644 index 0000000..efe83b8 --- /dev/null +++ b/test/nesting @@ -0,0 +1 @@ +echo 'foo "bar"' diff --git a/test/pipe b/test/pipe index 1cc500e..b1aa416 100644 --- a/test/pipe +++ b/test/pipe @@ -1 +1 @@ -echo a b c | grep -v a | cat +echo -e 'a\nb\nc' | grep -v b | cat diff --git a/test/substitution b/test/substitution index 3e31c5c..5c1f26d 100644 --- a/test/substitution +++ b/test/substitution @@ -1 +1 @@ -$(ls) +echo "$(ls)" From ad4098e4a4133cfba3044dd4d1fdd089ec840753 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Tue, 20 Sep 2016 11:54:42 +0200 Subject: [PATCH 017/312] error detection --- sh/peg.scm | 36 ++++++++++++++++-------------------- 1 file changed, 16 insertions(+), 20 deletions(-) diff --git a/sh/peg.scm b/sh/peg.scm index 1b519c4..147611b 100644 --- a/sh/peg.scm +++ b/sh/peg.scm @@ -16,6 +16,7 @@ (if (string-prefix? label (substring str pos)) (list (+ pos (string-length label)) '()) #f)) + (define-peg-pattern error all (followed-by peg-any)) (define-peg-pattern here-label none label-name) (define-peg-pattern here-delim none label-match) (define-peg-pattern here-document all (and (+ (and (not-followed-by here-delim) peg-any)) here-delim)) @@ -29,21 +30,22 @@ pipe <-- '|' command <-- simple-command / (compound-command (sp+ io-redirect)*) / function-def compound-command <-- brace-group / subshell / for-clause / case-clause / if-clause / while-clause / until-clause - subshell <-- '(' compound-list ')' + subshell <-- '(' ne-compound-list ')' compound-list <-- ws* term (separator term)* separator? - case-clause <-- 'case' sp+ word ws+ 'in' ws+ case-item* 'esac' + ne-compound-list <-- compound-list / error + case-clause <-- 'case' (sp+ word ws+ 'in' ws+ case-item* 'esac' / error) case-item <-- sp* pattern sp* ')' compound-list? ws* case-sep ws case-sep < ';;' pattern <-- word (sp* '|' sp* word)* - for-clause <-- 'for' sp+ identifier ws+ ('in' (sp+ word)* sp* sequential-sep)? do-group - do-group <-- 'do' compound-list 'done' - if-clause <-- 'if' compound-list 'then' compound-list else-part? 'fi' - else-part <-- ('elif' compound-list 'then' compound-list else-part?) / ('else' compound-list) - while-clause <-- 'while' compound-list do-group - until-clause <-- 'until' compound-list do-group - function-def <-- name sp* '(' sp* ')' ws* function-body + for-clause <-- 'for' (sp+ identifier ws+ ('in' (sp+ word)* sp* sequential-sep)? do-group / error) + do-group <-- 'do' (ne-compound-list 'done' / error) + if-clause <-- 'if' (ne-compound-list 'then' ne-compound-list else-part? 'fi' / error) + else-part <-- ('elif' (ne-compound-list 'then' ne-compound-list else-part? / error)) / ('else' (ne-compound-list / error)) + while-clause <-- 'while' (ne-compound-list do-group / error) + until-clause <-- 'until' (ne-compound-list do-group / error) + function-def <-- name sp* '(' sp* ')' ws* (function-body / error) function-body <-- compound-command io-redirect* - brace-group <-- '{' sp* compound-list sp* '}' + brace-group <-- '{' (sp* ne-compound-list sp* '}' / error) simple-command <-- (io-redirect sp+)* (!(reserved ws+) word) (sp+ (io-redirect / (!(reserved ws+) word)))* reserved < ('case' / 'esac' / 'if' / 'fi' / 'then' / 'else' / 'elif' / 'for' / 'done' / 'do' / 'until' / 'while') io-redirect <-- [0-9]* sp* (io-here / io-file) @@ -59,7 +61,7 @@ test <-- ltest (!rtest .)* rtest ltest < '[ ' rtest < ' ]' - substitution <-- ('$(' 'ls' ')') / ('`' script '`') + substitution <-- ('$(' (script ')' / error)) / ('`' (script '`' / error)) assignment <-- name assign word? assign < '=' literal <-- (subst / delim / (![0-9] (![()] !io-op !sp !nl !break !pipe !assign .)+) / ([0-9]+ &separator)) literal* @@ -68,9 +70,9 @@ sq < ['] dq < [\"] bt < [`] - singlequotes <-- (sq (doublequotes / backticks / (!sq .))* sq) - doublequotes <-- (dq (singlequotes / backticks / (!dq .))* dq) - backticks <-- (bt (singlequotes / doublequotes / (!bt .))* bt) + singlequotes <-- sq ((doublequotes / backticks / (!sq .))* sq / error) + doublequotes <-- dq ((singlequotes / backticks / (!dq .))* dq / error) + backticks <-- bt ((singlequotes / doublequotes / (!bt .))* bt / error) separator <-- (sp* break !semi ws*) / ws* break <-- amp / semi sequential-sep <-- (semi ws*) / ws+ @@ -89,9 +91,3 @@ (pretty-print (peg:end match)) #f) (peg:tree match)))) - - -;; (display 'foo) -;; (newline) -;; (display (parse "for f in a b; do echo $f; ls; done")) -;; (newline) From 72397d937eaf6e803b2d83bf136a22ef3666c2ca Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Tue, 20 Sep 2016 13:04:31 +0200 Subject: [PATCH 018/312] refactor for error handling --- sh/peg.scm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/sh/peg.scm b/sh/peg.scm index 147611b..fe316dc 100644 --- a/sh/peg.scm +++ b/sh/peg.scm @@ -83,11 +83,12 @@ ws < sp / nl ") -(let ((match (match-pattern script input))) +(let* ((match (match-pattern script input)) + (tree (peg:tree match))) (if (not (eq? (string-length input) (peg:end match))) - (let ((tree (peg:tree match))) - (pretty-print (peg:tree match)) + (begin + (pretty-print tree) (pretty-print "parse error" (current-error-port)) (pretty-print (peg:end match)) #f) - (peg:tree match)))) + tree))) From c201b080d04ed597e5147caae4c7b24e0a3bb4cf Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Thu, 22 Sep 2016 00:21:28 +0200 Subject: [PATCH 019/312] add error handling and reporting --- sh/anguish.scm | 4 +- sh/peg.scm | 155 +++++++++++++++++++++++++++---------------------- 2 files changed, 87 insertions(+), 72 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 56a73af..c240d66 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -35,8 +35,8 @@ (run (lambda (ast) (and ast (cond (parse? (let ((ast- (transform ast))) - (display "parsed : ") (display ast) (newline)(newline) - (display "prepared: ") (display ast-) (newline)(newline) + (format (current-output-port) "parsed : ~s\n\n" ast) + (format (current-output-port) "prepared: ~s\n\n" ast-) #t)) (#t (sh-exec ast) diff --git a/sh/peg.scm b/sh/peg.scm index fe316dc..0be0b04 100644 --- a/sh/peg.scm +++ b/sh/peg.scm @@ -4,7 +4,24 @@ :use-module (ice-9 pretty-print) :export (parse)) +(define (error? x) + (let loop ((x x)) + (if (null? x) #f + (if (not (pair? x)) + (eq? 'error x) + (or (loop (car x)) + (loop (cdr x))))))) + (define (parse input) + (let ((tree (parse- input))) + (and tree + (cond ((error? tree) + (format (current-error-port) "error:~s\n" tree) + #f) + (#t + tree))))) + +(define (parse- input) (define label "") (define (label-name str len pos) (let ((at (string-skip str char-alphabetic? pos len))) @@ -21,74 +38,72 @@ (define-peg-pattern here-delim none label-match) (define-peg-pattern here-document all (and (+ (and (not-followed-by here-delim) peg-any)) here-delim)) -(define-peg-string-patterns -"script <-- ws* (term (separator term)* separator?)? - term <-- pipeline (sp* (and / or) ws* pipeline)* - and <-- '&&' - or <-- '||' - pipeline <-- '!'? sp* command (sp* pipe ws* command)* - pipe <-- '|' - command <-- simple-command / (compound-command (sp+ io-redirect)*) / function-def - compound-command <-- brace-group / subshell / for-clause / case-clause / if-clause / while-clause / until-clause - subshell <-- '(' ne-compound-list ')' - compound-list <-- ws* term (separator term)* separator? - ne-compound-list <-- compound-list / error - case-clause <-- 'case' (sp+ word ws+ 'in' ws+ case-item* 'esac' / error) - case-item <-- sp* pattern sp* ')' compound-list? ws* case-sep ws - case-sep < ';;' - pattern <-- word (sp* '|' sp* word)* - for-clause <-- 'for' (sp+ identifier ws+ ('in' (sp+ word)* sp* sequential-sep)? do-group / error) - do-group <-- 'do' (ne-compound-list 'done' / error) - if-clause <-- 'if' (ne-compound-list 'then' ne-compound-list else-part? 'fi' / error) - else-part <-- ('elif' (ne-compound-list 'then' ne-compound-list else-part? / error)) / ('else' (ne-compound-list / error)) - while-clause <-- 'while' (ne-compound-list do-group / error) - until-clause <-- 'until' (ne-compound-list do-group / error) - function-def <-- name sp* '(' sp* ')' ws* (function-body / error) - function-body <-- compound-command io-redirect* - brace-group <-- '{' (sp* ne-compound-list sp* '}' / error) - simple-command <-- (io-redirect sp+)* (!(reserved ws+) word) (sp+ (io-redirect / (!(reserved ws+) word)))* - reserved < ('case' / 'esac' / 'if' / 'fi' / 'then' / 'else' / 'elif' / 'for' / 'done' / 'do' / 'until' / 'while') - io-redirect <-- [0-9]* sp* (io-here / io-file) - io-file <-- ('<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|') sp* ([0-9]+ / filename) - io-here <- ('<<' / '<<-') io-suffix here-document - io-op < '<<-' / '<<' / '<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|' - io-suffix <- sp* here-label sp* nl - filename <-- word - name <-- identifier - identifier <- [_a-zA-Z][_a-zA-Z0-9]* - word <-- test / substitution / assignment / literal / number - number <-- [0-9]+ - test <-- ltest (!rtest .)* rtest - ltest < '[ ' - rtest < ' ]' - substitution <-- ('$(' (script ')' / error)) / ('`' (script '`' / error)) - assignment <-- name assign word? - assign < '=' - literal <-- (subst / delim / (![0-9] (![()] !io-op !sp !nl !break !pipe !assign .)+) / ([0-9]+ &separator)) literal* - subst <-- '$' ('$' / '*' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) - delim <-- singlequotes / doublequotes / backticks - sq < ['] - dq < [\"] - bt < [`] - singlequotes <-- sq ((doublequotes / backticks / (!sq .))* sq / error) - doublequotes <-- dq ((singlequotes / backticks / (!dq .))* dq / error) - backticks <-- bt ((singlequotes / doublequotes / (!bt .))* bt / error) - separator <-- (sp* break !semi ws*) / ws* - break <-- amp / semi - sequential-sep <-- (semi ws*) / ws+ - amp < '&' - semi < ';' - nl < '\n' - sp < [\t ] - ws < sp / nl -") + (define-peg-string-patterns + "script <-- ws* (term (separator term)* separator?)? + term <-- pipeline (sp* (and / or) ws* pipeline)* + and <-- '&&' + or <-- '||' + pipeline <-- '!'? sp* command (sp* pipe ws* command)* + pipe <-- '|' + command <-- simple-command / (compound-command (sp+ io-redirect)*) / function-def + compound-command <-- brace-group / subshell / for-clause / case-clause / if-clause / while-clause / until-clause + subshell <-- '(' ne-compound-list ')' + compound-list <-- ws* term (separator term)* separator? + ne-compound-list <-- compound-list / error + case-clause <-- 'case' (sp+ word ws+ 'in' ws+ case-item* 'esac' / error) + case-item <-- sp* pattern sp* ')' compound-list? ws* case-sep ws + case-sep < ';;' + pattern <-- word (sp* '|' sp* word)* + for-clause <-- 'for' (sp+ identifier ws+ ('in' (sp+ word)* sp* sequential-sep)? do-group / error) + do-group <-- 'do' (ne-compound-list 'done' / error) + if-clause <-- 'if' (ne-compound-list 'then' ne-compound-list else-part? 'fi' / error) + else-part <-- ('elif' (ne-compound-list 'then' ne-compound-list else-part? / error)) / ('else' (ne-compound-list / error)) + while-clause <-- 'while' (ne-compound-list do-group / error) + until-clause <-- 'until' (ne-compound-list do-group / error) + function-def <-- name sp* '(' sp* ')' ws* (function-body / error) + function-body <-- compound-command io-redirect* + brace-group <-- '{' (sp* ne-compound-list sp* '}' / error) + simple-command <-- (io-redirect sp+)* (!(reserved ws+) word) (sp+ (io-redirect / (!(reserved ws+) word)))* + reserved < ('case' / 'esac' / 'if' / 'fi' / 'then' / 'else' / 'elif' / 'for' / 'done' / 'do' / 'until' / 'while') + io-redirect <-- [0-9]* sp* (io-here / io-file) + io-file <-- ('<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|') sp* ([0-9]+ / filename) + io-here <- ('<<' / '<<-') io-suffix here-document + io-op < '<<-' / '<<' / '<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|' + io-suffix <- sp* here-label sp* nl + filename <-- word + name <-- identifier + identifier <- [_a-zA-Z][_a-zA-Z0-9]* + word <-- test / substitution / assignment / literal / number + number <-- [0-9]+ + test <-- ltest (!rtest .)* rtest + ltest < '[ ' + rtest < ' ]' + substitution <-- ('$(' (script ')' / error)) / ('`' (script '`' / error)) + assignment <-- name assign word? + assign < '=' + literal <-- (subst / delim / (![0-9] (![()] !io-op !sp !nl !break !pipe !assign .)+) / ([0-9]+ &separator)) literal* + subst <-- '$' ('$' / '*' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) + delim <-- singlequotes / doublequotes / backticks + sq < ['] + dq < [\"] + bt < [`] + singlequotes <-- sq ((doublequotes / backticks / (!sq .))* sq / error) + doublequotes <-- dq ((singlequotes / backticks / (!dq .))* dq / error) + backticks <-- bt ((singlequotes / doublequotes / (!bt .))* bt / error) + separator <-- (sp* break !semi ws*) / ws* + break <-- amp / semi + sequential-sep <-- (semi ws*) / ws+ + amp < '&' + semi < ';' + nl < '\n' + sp < [\t ] + ws < sp / nl") -(let* ((match (match-pattern script input)) - (tree (peg:tree match))) - (if (not (eq? (string-length input) (peg:end match))) - (begin - (pretty-print tree) - (pretty-print "parse error" (current-error-port)) - (pretty-print (peg:end match)) - #f) - tree))) + (let* ((match (match-pattern script input)) + (end (peg:end match)) + (tree (peg:tree match))) + (if (eq? (string-length input) end) + tree + (begin + (format (current-error-port) "parse error: at offset: ~a\n~s\n" end tree) + #f)))) From a5c35947a9d219d07f31d5cb95c7dfb965713c16 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 5 Oct 2016 15:50:50 +0200 Subject: [PATCH 020/312] ifthen WIP --- anguish | 2 +- sh/anguish.scm | 7 ++++++- test/ifthen | 2 +- 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/anguish b/anguish index 488d4d1..bdbce94 100755 --- a/anguish +++ b/anguish @@ -1,5 +1,5 @@ #!/usr/bin/guile-2.2 \ --e main -s +--debug -e main -s !# ;; workaround: ;; -e (@ (sh anguish) main) -s diff --git a/sh/anguish.scm b/sh/anguish.scm index c240d66..b647774 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -97,6 +97,9 @@ copyleft. (define (transform ast) (match ast (('script command 'separator) (transform command)) + (('if-clause "if" (expression "then" consequent "fi")) `(if ,(transform expression) ,(transform consequent))) + (('if-clause "if" expression "then" consequent "else" alternative "fi") `(if ,(transform expression) ,(transform consequent) ,(transform alternative))) + (('compound-list command ('separator 'break)) (transform command)) (('pipeline command) (transform command)) (('pipeline command piped-commands) (cons 'pipeline (cons (transform command) (transform piped-commands)))) (('simple-command ('word s)) (list (transform s))) @@ -121,7 +124,9 @@ copyleft. ((builtin cmd)) (if (and (pair? cmd) (eq? 'pipeline (car cmd))) (sh:pipeline (cdr cmd)) - (apply system* cmd))))) + (if (eq? 'if (car cmd)) + (pretty-print cmd) + (apply system* cmd)))))) (define (prompt) (let* ((esc (string #\033)) diff --git a/test/ifthen b/test/ifthen index 2c1e983..5d36280 100644 --- a/test/ifthen +++ b/test/ifthen @@ -1 +1 @@ -if ls * | grep foo; then echo ok; fi +if test -e TODO; then echo exists; fi From d5800f2d31af87f0e607c2df0ab51f7f380cabd9 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Fri, 7 Oct 2016 23:02:54 +0200 Subject: [PATCH 021/312] somewhat decent stack trace --- stack.scm | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) create mode 100644 stack.scm diff --git a/stack.scm b/stack.scm new file mode 100644 index 0000000..7b8573c --- /dev/null +++ b/stack.scm @@ -0,0 +1,50 @@ +(use-modules (ice-9 match)) + +(use-modules (system vm frame) + (system vm trace)) + +(define (location frame) + (let ((source (frame-source frame))) + (if source + (string-append (cadr source) ":" + (number->string (caddr source)) ":") + source))) + +(define (stack-trace) + (let ((skip-stack-capture-crap 4) + (stack (make-stack #t))) + (filter identity (let loop ((frame (stack-ref stack skip-stack-capture-crap))) + (if (not (frame? frame)) '() + (cons (location frame) (loop (frame-previous frame)))))))) + +(define (main) + (catch #t + (lambda () + (with-throw-handler + #t + foo + (lambda (key . args) + (stdout "error: " args) + (throw 'exception (stack-trace))))) + (lambda (key . args) + (map stdout (car args))))) + +(define (foo) + (bar) + (format (current-output-port) "foo\n")) + +(define (stdout . o) + (map (lambda (o) (display o (current-output-port))) o) + (newline) + o) + +(define (bar) + (define (blurp o) + (match o + ('a 'a) + ('c 'c) + ((? pair?) (map blurp o)))) + (blurp '(a b)) + (format (current-output-port) "bar\n")) + +(main) From 8fbcf9a83f616461df017b931c9c1cf1820e97d3 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sun, 9 Oct 2016 21:12:17 +0200 Subject: [PATCH 022/312] display function args --- stack.scm | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/stack.scm b/stack.scm index 7b8573c..f6de391 100644 --- a/stack.scm +++ b/stack.scm @@ -3,15 +3,26 @@ (use-modules (system vm frame) (system vm trace)) +(define (to-string o) + (match o + ((? string?) o) + ((? symbol?) (symbol->string o)) + ((? number?) (number->string o)) + ((? list?) (string-join (map to-string o) " ")) + ((? pair?) (string-join (list (to-string (car o)) (to-string (cdr o))) " ")) + (_ "???"))) + (define (location frame) (let ((source (frame-source frame))) (if source - (string-append (cadr source) ":" - (number->string (caddr source)) ":") + (let* ((args (frame-arguments frame)) + (args (if (null? args) "" (string-append " args: " (to-string args))))) + (string-append (cadr source) ":" + (number->string (caddr source)) ":" args)) source))) (define (stack-trace) - (let ((skip-stack-capture-crap 4) + (let ((skip-stack-capture-crap 0) (stack (make-stack #t))) (filter identity (let loop ((frame (stack-ref stack skip-stack-capture-crap))) (if (not (frame? frame)) '() @@ -30,7 +41,7 @@ (map stdout (car args))))) (define (foo) - (bar) + (bar '(a b)) (format (current-output-port) "foo\n")) (define (stdout . o) @@ -38,13 +49,10 @@ (newline) o) -(define (bar) - (define (blurp o) - (match o - ('a 'a) - ('c 'c) - ((? pair?) (map blurp o)))) - (blurp '(a b)) +(define (bar arg) + (match arg + ('a 'a) + ((? pair?) (map bar arg))) (format (current-output-port) "bar\n")) (main) From d874664dc3c5be0e54bba16f361c8adc7951a2a4 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sun, 9 Oct 2016 21:21:08 +0200 Subject: [PATCH 023/312] implement if-then-else --- sh/anguish.scm | 41 +++++++++++++++++++++++++---------------- sh/peg.scm | 45 +++++++++++++++++++++++++-------------------- 2 files changed, 50 insertions(+), 36 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index b647774..1ecca1e 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -12,6 +12,16 @@ (use-modules ((sh pipe) :renamer (symbol-prefix-proc 'sh:))) (use-modules ((sh peg) :renamer (symbol-prefix-proc 'sh:))) +(define (stdout . o) + (map (lambda (o) (display o (current-output-port))) o) + (newline) + o) + +(define (stderr . o) + (map (lambda (o) (display o (current-error-port))) o) + (newline) + o) + (define (file-to-string filename) ((compose read-string open-input-file) filename)) @@ -89,17 +99,12 @@ copyleft. s))) (string-split s #\newline)) "\n")) -(define (builtin cmd) - (if (and (pair? cmd) (string? (car cmd)) (string=? (car cmd) "cd")) - (lambda () (chdir (cadr cmd))) - #f)) - (define (transform ast) (match ast - (('script command 'separator) (transform command)) + (('script command) (transform command)) + (('script command separator) (transform command)) (('if-clause "if" (expression "then" consequent "fi")) `(if ,(transform expression) ,(transform consequent))) - (('if-clause "if" expression "then" consequent "else" alternative "fi") `(if ,(transform expression) ,(transform consequent) ,(transform alternative))) - (('compound-list command ('separator 'break)) (transform command)) + (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) `(if ,(transform expression) ,(transform consequent) ,(transform alternative))) (('pipeline command) (transform command)) (('pipeline command piped-commands) (cons 'pipeline (cons (transform command) (transform piped-commands)))) (('simple-command ('word s)) (list (transform s))) @@ -118,15 +123,19 @@ copyleft. (_ ast))) (define (sh-exec ast) + ;;(stdout "parsed: " ast) (let ((cmd (transform ast))) - ;(display "executing: ")(display cmd) (newline) - (if (builtin cmd) - ((builtin cmd)) - (if (and (pair? cmd) (eq? 'pipeline (car cmd))) - (sh:pipeline (cdr cmd)) - (if (eq? 'if (car cmd)) - (pretty-print cmd) - (apply system* cmd)))))) + ;;(stdout "executing: " cmd) + (match cmd + (("cd" argument ...) (apply chdir argument)) + (('if expression consequent) (if (equal? 0 (status:exit-val (apply system* expression))) + (apply system* consequent))) + (('if expression consequent alternative) (if (equal? 0 (status:exit-val (apply system* expression))) + (apply system* consequent) + (apply system* alternative))) + (('pipeline command ...) (sh:pipeline command)) + ('script '()) + (_ (apply system* cmd))))) (define (prompt) (let* ((esc (string #\033)) diff --git a/sh/peg.scm b/sh/peg.scm index 0be0b04..b345ad6 100644 --- a/sh/peg.scm +++ b/sh/peg.scm @@ -16,7 +16,7 @@ (let ((tree (parse- input))) (and tree (cond ((error? tree) - (format (current-error-port) "error:~s\n" tree) + (format (current-error-port) "error: ~a\n" tree) #f) (#t tree))))) @@ -33,13 +33,14 @@ (if (string-prefix? label (substring str pos)) (list (+ pos (string-length label)) '()) #f)) - (define-peg-pattern error all (followed-by peg-any)) (define-peg-pattern here-label none label-name) (define-peg-pattern here-delim none label-match) (define-peg-pattern here-document all (and (+ (and (not-followed-by here-delim) peg-any)) here-delim)) (define-peg-string-patterns - "script <-- ws* (term (separator term)* separator?)? + "script <-- ws* (term (separator term)* separator?)? eof + eof < !. / error + error <-- .* term <-- pipeline (sp* (and / or) ws* pipeline)* and <-- '&&' or <-- '||' @@ -48,22 +49,22 @@ command <-- simple-command / (compound-command (sp+ io-redirect)*) / function-def compound-command <-- brace-group / subshell / for-clause / case-clause / if-clause / while-clause / until-clause subshell <-- '(' ne-compound-list ')' - compound-list <-- ws* term (separator term)* separator? - ne-compound-list <-- compound-list / error - case-clause <-- 'case' (sp+ word ws+ 'in' ws+ case-item* 'esac' / error) - case-item <-- sp* pattern sp* ')' compound-list? ws* case-sep ws + compound-list <-- term (separator term)* + ne-compound-list <-- compound-list separator / error + case-clause <-- 'case' sp+ word ws+ 'in' ws+ case-item* 'esac' + case-item <-- pattern (ne-compound-list? case-sep ws* / error) case-sep < ';;' - pattern <-- word (sp* '|' sp* word)* + pattern <-- sp* word (sp* '|' sp* word)* sp* ')' sp* for-clause <-- 'for' (sp+ identifier ws+ ('in' (sp+ word)* sp* sequential-sep)? do-group / error) do-group <-- 'do' (ne-compound-list 'done' / error) if-clause <-- 'if' (ne-compound-list 'then' ne-compound-list else-part? 'fi' / error) - else-part <-- ('elif' (ne-compound-list 'then' ne-compound-list else-part? / error)) / ('else' (ne-compound-list / error)) + else-part <-- 'elif' (ne-compound-list 'then' ne-compound-list else-part? / error) / 'else' (ne-compound-list / error) while-clause <-- 'while' (ne-compound-list do-group / error) until-clause <-- 'until' (ne-compound-list do-group / error) function-def <-- name sp* '(' sp* ')' ws* (function-body / error) function-body <-- compound-command io-redirect* - brace-group <-- '{' (sp* ne-compound-list sp* '}' / error) - simple-command <-- (io-redirect sp+)* (!(reserved ws+) word) (sp+ (io-redirect / (!(reserved ws+) word)))* + brace-group <-- '{' (sp* (compound-list / error) sp* '}' / error) + simple-command <-- (io-redirect sp+)* !(reserved ws+) word (sp+ (io-redirect / (!(reserved ws+) word)))* reserved < ('case' / 'esac' / 'if' / 'fi' / 'then' / 'else' / 'elif' / 'for' / 'done' / 'do' / 'until' / 'while') io-redirect <-- [0-9]* sp* (io-here / io-file) io-file <-- ('<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|') sp* ([0-9]+ / filename) @@ -87,12 +88,12 @@ sq < ['] dq < [\"] bt < [`] - singlequotes <-- sq ((doublequotes / backticks / (!sq .))* sq / error) - doublequotes <-- dq ((singlequotes / backticks / (!dq .))* dq / error) - backticks <-- bt ((singlequotes / doublequotes / (!bt .))* bt / error) - separator <-- (sp* break !semi ws*) / ws* - break <-- amp / semi - sequential-sep <-- (semi ws*) / ws+ + singlequotes <-- sq ((doublequotes / backticks / (!sq .))* sq) + doublequotes <-- dq ((singlequotes / backticks / (!dq .))* dq) + backticks <-- bt ((singlequotes / doublequotes / (!bt .))* bt) + separator < (sp* break ws*) / ws+ + break <-- amp / semi !semi + sequential-sep <-- (semi !semi ws*) / ws+ amp < '&' semi < ';' nl < '\n' @@ -104,6 +105,10 @@ (tree (peg:tree match))) (if (eq? (string-length input) end) tree - (begin - (format (current-error-port) "parse error: at offset: ~a\n~s\n" end tree) - #f)))) + (if match + (begin + (format (current-error-port) "parse error: at offset: ~a\n~s\n" end tree) + #f) + (begin + (format (current-error-port) "parse error: no match\n") + #f))))) From f25569da273662ea6240fb29bd5ce7df652a840d Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Mon, 10 Oct 2016 09:54:18 +0200 Subject: [PATCH 024/312] simplify pipeline signature --- sh/pipe.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/sh/pipe.scm b/sh/pipe.scm index c38350f..61e5dd4 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -44,7 +44,7 @@ (close src) (waitpid pid))))) -(define (pipeline commands) +(define (pipeline . commands) (if (< 1 (length commands)) (let loop ((src (spawn-source (car commands))) (commands (cdr commands))) @@ -52,4 +52,4 @@ (loop (spawn-filter src (car commands)) (cdr commands)))))) -;;(pipeline (list (list "ls" "/") (list "grep" "o") (list "tr" "o" "e"))) +;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) From f04d3d2b5f19c0d38d4ba7f2e6189d9880254df1 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Mon, 10 Oct 2016 09:55:38 +0200 Subject: [PATCH 025/312] transform ast -> sexp => (sh-exec sexp (local-eval sexp (the-environment))) --- sh/anguish.scm | 69 +++++++++++++++++++++++++++++++------------------- 1 file changed, 43 insertions(+), 26 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 1ecca1e..67bc508 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -1,17 +1,19 @@ (define-module (sh anguish) :use-module (srfi srfi-1) + :use-module (srfi srfi-26) :use-module (ice-9 getopt-long) :use-module (ice-9 match) :use-module (ice-9 pretty-print) :use-module (ice-9 rdelim) :use-module (ice-9 readline) :use-module (ice-9 ftw) + :use-module (ice-9 local-eval) + + :use-module (sh pipe) + :use-module (sh peg) :export (main)) -(use-modules ((sh pipe) :renamer (symbol-prefix-proc 'sh:))) -(use-modules ((sh peg) :renamer (symbol-prefix-proc 'sh:))) - (define (stdout . o) (map (lambda (o) (display o (current-output-port))) o) (newline) @@ -26,7 +28,7 @@ ((compose read-string open-input-file) filename)) (define (string-to-ast string) - ((compose sh:parse remove-shell-comments) string)) + ((compose parse remove-shell-comments) string)) (define (file-to-ast filename) ((compose string-to-ast file-to-string) filename)) @@ -99,17 +101,38 @@ copyleft. s))) (string-split s #\newline)) "\n")) +(define (expand identifier o) ;;identifier-string -> symbol + (define (foo o) + (let ((dollar-identifier (string-append "$" identifier))) + (match o + ((? symbol?) o) + ((? string?) (if (string=? o dollar-identifier) (string->symbol identifier) o)) + ((? list?) (map foo o))))) + (map foo o)) + +(define (glob o) ;;HAX0R, more todo + (define (foo o) + (match o + ("*" (map car (cddr (file-system-tree (getcwd))))) + ((? symbol?) o) + ((? string?) o) + ((? list?) (map foo o)) + (_ o))) + (map foo o)) + (define (transform ast) (match ast (('script command) (transform command)) (('script command separator) (transform command)) - (('if-clause "if" (expression "then" consequent "fi")) `(if ,(transform expression) ,(transform consequent))) - (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) `(if ,(transform expression) ,(transform consequent) ,(transform alternative))) - (('pipeline command) (transform command)) + (('if-clause "if" (expression "then" consequent "fi")) `(if (equal? 0 (status:exit-val ,(transform expression))) ,(transform consequent))) + (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) `(if (equal? 0 (status:exit-val ,(transform expression))) ,(transform consequent) ,(transform alternative))) + (('for-clause "for" ((identifier "in" lst sep) do-group)) (list 'for-each (list 'lambda (list (string->symbol identifier)) (expand identifier (transform do-group))) (cons 'list (transform (glob lst))))) + (('do-group "do" (command "done")) (transform command)) + (('pipeline command) (let ((command (transform command))) (if (eq? 'list (car command)) `(apply system* ,command) command))) (('pipeline command piped-commands) (cons 'pipeline (cons (transform command) (transform piped-commands)))) - (('simple-command ('word s)) (list (transform s))) - (('simple-command ('word s1) ('word s2)) (list (transform s1) (transform s2))) - (('simple-command ('word s1) (('word s2) ...)) (cons (transform s1) (map transform s2))) + (('simple-command ('word s)) `(list ,(transform s))) + (('simple-command ('word s1) ('word s2)) `(list ,(transform s1) ,(transform s2))) + (('simple-command ('word s1) (('word s2) ...)) (append `(list ,(transform s1)) (map transform s2))) (('literal s) (transform s)) (('singlequotes s) (string-concatenate (list "'" s "'"))) (('doublequotes s) (string-concatenate (list "\"" s "\""))) @@ -119,23 +142,17 @@ copyleft. (('delim ('backticks s ...)) (string-concatenate (map transform s))) ((('pipe _) command ...) (map transform command)) (((('pipe _) command) ...) (map transform command)) - ((_ o) (transform o)) + ((_ o) (transform o)) ;;peel the onion: (symbol (...)) -> (...) (_ ast))) -(define (sh-exec ast) +(define (sh-exec ast) ;; (local-eval (transform ast) (the-environment)) ;;(stdout "parsed: " ast) (let ((cmd (transform ast))) ;;(stdout "executing: " cmd) (match cmd - (("cd" argument ...) (apply chdir argument)) - (('if expression consequent) (if (equal? 0 (status:exit-val (apply system* expression))) - (apply system* consequent))) - (('if expression consequent alternative) (if (equal? 0 (status:exit-val (apply system* expression))) - (apply system* consequent) - (apply system* alternative))) - (('pipeline command ...) (sh:pipeline command)) + (('list "cd" argument ...) (apply chdir argument)) ('script '()) - (_ (apply system* cmd))))) + (_ (local-eval cmd (the-environment)))))) (define (prompt) (let* ((esc (string #\033)) @@ -144,7 +161,7 @@ copyleft. (cwd (if (string-prefix? HOME CWD) (string-replace CWD "~" 0 (string-length HOME)) CWD))) - (string-append esc "[01;34m" cwd esc "[00m$ "))) + (string-append esc "[01;34m" cwd esc "[00m$ "))) (define (redraw-current-line) (dynamic-call (dynamic-func "rl_refresh_line" @@ -154,8 +171,8 @@ copyleft. (define (filename-completion text state) (if (not state) (let ((completions (map car - (filter (lambda (entry) (string-prefix? text (car entry))) - (cddr (file-system-tree (getcwd))))))) + (filter (cut string-prefix? text <>) + (map car (cddr (file-system-tree (getcwd)))))))) (cond ((< 1 (length completions)) (begin (newline) (display (string-join completions " ")) (newline) (redraw-current-line) @@ -167,8 +184,8 @@ copyleft. (define (search-binary-in-path-completion text state) (if (not state) (let ((completions (map car - (filter (lambda (entry) (string-prefix? text (car entry))) - (cddr (file-system-tree "/bin")))))) + (filter (cut string-prefix? text <>) + (map car (cddr (file-system-tree "/bin"))))))) (cond ((< 1 (length completions)) (begin (newline) (display (string-join completions " ")) (newline) (redraw-current-line) @@ -179,5 +196,5 @@ copyleft. (define (completion text state) (or (filename-completion text state) - ;(search-binary-in-path-completion text state) + ;;(search-binary-in-path-completion text state) )) From be25278d6cae0cd83d9adbf8dd044e4361bff9f3 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Mon, 10 Oct 2016 14:41:51 +0200 Subject: [PATCH 026/312] self-test support: cd test; ../anguish ../test.sh --- sh/anguish.scm | 28 +++++++++++------- test.sh | 79 +------------------------------------------------- 2 files changed, 19 insertions(+), 88 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 67bc508..655963d 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -120,9 +120,14 @@ copyleft. (_ o))) (map foo o)) +(define (builtin . ast) + (match ast + (("cd" arg) `(chdir ,arg)) + (_ `(apply system* ,(cons 'list ast))))) + (define (transform ast) (match ast - (('script command) (transform command)) + (('script command ...) (cons 'list (map transform command))) (('script command separator) (transform command)) (('if-clause "if" (expression "then" consequent "fi")) `(if (equal? 0 (status:exit-val ,(transform expression))) ,(transform consequent))) (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) `(if (equal? 0 (status:exit-val ,(transform expression))) ,(transform consequent) ,(transform alternative))) @@ -131,8 +136,8 @@ copyleft. (('pipeline command) (let ((command (transform command))) (if (eq? 'list (car command)) `(apply system* ,command) command))) (('pipeline command piped-commands) (cons 'pipeline (cons (transform command) (transform piped-commands)))) (('simple-command ('word s)) `(list ,(transform s))) - (('simple-command ('word s1) ('word s2)) `(list ,(transform s1) ,(transform s2))) - (('simple-command ('word s1) (('word s2) ...)) (append `(list ,(transform s1)) (map transform s2))) + (('simple-command ('word s1) ('word s2)) (builtin (transform s1) (transform s2))) + (('simple-command ('word s1) (('word s2) ...)) (apply builtin (append (list (transform s1)) (map transform s2)))) (('literal s) (transform s)) (('singlequotes s) (string-concatenate (list "'" s "'"))) (('doublequotes s) (string-concatenate (list "\"" s "\""))) @@ -146,13 +151,16 @@ copyleft. (_ ast))) (define (sh-exec ast) ;; (local-eval (transform ast) (the-environment)) - ;;(stdout "parsed: " ast) + (define (exec cmd) + (local-eval cmd (the-environment))) + + (stdout "parsed: " ast) (let ((cmd (transform ast))) - ;;(stdout "executing: " cmd) + (stdout "executing: " cmd) (match cmd - (('list "cd" argument ...) (apply chdir argument)) - ('script '()) - (_ (local-eval cmd (the-environment)))))) + ('script '()) ;; skip + (('list cmd ...) (map exec cmd)) + (_ (exec cmd))))) (define (prompt) (let* ((esc (string #\033)) @@ -171,7 +179,7 @@ copyleft. (define (filename-completion text state) (if (not state) (let ((completions (map car - (filter (cut string-prefix? text <>) + (filter (cute string-prefix? text <>) (map car (cddr (file-system-tree (getcwd)))))))) (cond ((< 1 (length completions)) (begin (newline) (display (string-join completions " ")) (newline) @@ -184,7 +192,7 @@ copyleft. (define (search-binary-in-path-completion text state) (if (not state) (let ((completions (map car - (filter (cut string-prefix? text <>) + (filter (cute string-prefix? text <>) (map car (cddr (file-system-tree "/bin"))))))) (cond ((< 1 (length completions)) (begin (newline) (display (string-join completions " ")) (newline) diff --git a/test.sh b/test.sh index cb48edf..a7098d7 100644 --- a/test.sh +++ b/test.sh @@ -1,78 +1 @@ -cat <&1 -ls -l / -1 - -(echo; echo) - -if true -then - echo -fi - -for f in foo; do echo; done - -for file in *.im -do - ${bin}/asd -l gen2 ${file} 2>&1 codegenerator.log || error "codegenerator gen2 failure: ${file}" codegenerator.log -done - -cat foo || echo ok && echo nok - -foo=$* -foo=$@ -foo=$(dirname $(dirname $@)) - -foo || bar && baz - -${bin}/generate -p componentfile.dzn > pretty.dzn 2> pretty.err && cat pretty.dzn || cat componentfile.dzn - -filecount=-1 - -if [ "${file}" != "generator.log"\ - -a "${file}" != "gaiag.log"\ - -a "${file}" != "${basename}.scm"\ - -a "`basename ${file} .dzn`.dzn" != "${file}" ] -then - echo - filecount=$((filecount+1)) - #files[${filecount}]=${file} -fi - - -for file in $(find * -type f) -do - echo -done - -for file in $(find * -type f) -do - echo $file -done - -if ls& ls; then echo foo& echo bar || echo foo; echo barf; fi - -for f in foo bar; do echo; done -ls - -model=$1 -model= - -if [ "${model}" = "" ] -then - echo -fi +for f in *; do ../anguish -p $f; done From 1fefd6256251596b470f8d5861528812e11f9573 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Mon, 10 Oct 2016 23:09:58 +0200 Subject: [PATCH 027/312] regex based glob --- sh/anguish.scm | 45 +++++++++++++++++++++++++++++++-------------- 1 file changed, 31 insertions(+), 14 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 655963d..4004e2c 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -1,13 +1,14 @@ (define-module (sh anguish) :use-module (srfi srfi-1) :use-module (srfi srfi-26) + :use-module (ice-9 ftw) :use-module (ice-9 getopt-long) + :use-module (ice-9 local-eval) :use-module (ice-9 match) :use-module (ice-9 pretty-print) :use-module (ice-9 rdelim) :use-module (ice-9 readline) - :use-module (ice-9 ftw) - :use-module (ice-9 local-eval) + :use-module (ice-9 regex) :use-module (sh pipe) :use-module (sh peg) @@ -110,15 +111,31 @@ copyleft. ((? list?) (map foo o))))) (map foo o)) -(define (glob o) ;;HAX0R, more todo - (define (foo o) - (match o - ("*" (map car (cddr (file-system-tree (getcwd))))) - ((? symbol?) o) - ((? string?) o) - ((? list?) (map foo o)) - (_ o))) - (map foo o)) + +(define (glob pattern) ;; pattern -> list of path + (define (glob2regex pattern) + (let* ((pattern (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post)) + (pattern (regexp-substitute/global #f "\\?" pattern 'pre "." 'post)) + (pattern (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post))) + (make-regexp (string-append pattern "$")))) + + (define (glob-match pattern path) ;; pattern path -> bool + (regexp-match? (regexp-exec (glob2regex pattern) path))) + + (define (glob- pattern paths) + (append-map (lambda (path) + (let ((empty? (string=? "" path))) + (map (lambda (extension) (if empty? extension (string-join (list path "/" extension) ""))) + (filter (cute glob-match pattern <>) + (map car (cddr (file-system-tree (if empty? (getcwd) path)))))))) + paths)) + + (let ((absolute? (eq? #\/ (string-ref pattern 0)))) + (let loop ((patterns (string-split pattern #\/)) + (paths (if absolute? '("/") `("")))) + (if (null? patterns) paths + (loop (cdr patterns) (glob- (car patterns) paths)))))) + (define (builtin . ast) (match ast @@ -136,7 +153,7 @@ copyleft. (('pipeline command) (let ((command (transform command))) (if (eq? 'list (car command)) `(apply system* ,command) command))) (('pipeline command piped-commands) (cons 'pipeline (cons (transform command) (transform piped-commands)))) (('simple-command ('word s)) `(list ,(transform s))) - (('simple-command ('word s1) ('word s2)) (builtin (transform s1) (transform s2))) + (('simple-command ('word s1) ('word s2)) (apply builtin (append (list (transform s1)) (glob (transform s2))))) (('simple-command ('word s1) (('word s2) ...)) (apply builtin (append (list (transform s1)) (map transform s2)))) (('literal s) (transform s)) (('singlequotes s) (string-concatenate (list "'" s "'"))) @@ -154,9 +171,9 @@ copyleft. (define (exec cmd) (local-eval cmd (the-environment))) - (stdout "parsed: " ast) + ;;(stdout "parsed: " ast) (let ((cmd (transform ast))) - (stdout "executing: " cmd) + ;;(stdout "executing: " cmd) (match cmd ('script '()) ;; skip (('list cmd ...) (map exec cmd)) From 735288cfa2ee5bbc0f2d2681a01b3b569f6572d2 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Tue, 11 Oct 2016 10:39:24 +0200 Subject: [PATCH 028/312] function name WIP --- stack.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/stack.scm b/stack.scm index f6de391..065a7fd 100644 --- a/stack.scm +++ b/stack.scm @@ -16,7 +16,8 @@ (let ((source (frame-source frame))) (if source (let* ((args (frame-arguments frame)) - (args (if (null? args) "" (string-append " args: " (to-string args))))) + (args (if (null? args) "" (string-append " args: " (to-string args)))) + (foo (format (current-output-port) "~a\n" (frame-procedure frame)))) (string-append (cadr source) ":" (number->string (caddr source)) ":" args)) source))) From 12d7976dfd0eca1197187dfc4af7627e9da9470a Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Tue, 11 Oct 2016 10:44:09 +0200 Subject: [PATCH 029/312] implement globbing lazily such that (eval (save (transform (parse shell)))) is maintained. --- sh/anguish.scm | 54 ++++++++++++++++++++++++++++++-------------------- sh/pipe.scm | 3 ++- test/ls | 2 +- test/pipe | 2 +- 4 files changed, 37 insertions(+), 24 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 4004e2c..3b5a4e4 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -112,7 +112,12 @@ copyleft. (map foo o)) +;; TODO: add braces and pattern ending with / + (define (glob pattern) ;; pattern -> list of path + (define (glob? pattern) + (string-match "\\?|\\*" pattern)) + (define (glob2regex pattern) (let* ((pattern (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post)) (pattern (regexp-substitute/global #f "\\?" pattern 'pre "." 'post)) @@ -125,36 +130,44 @@ copyleft. (define (glob- pattern paths) (append-map (lambda (path) (let ((empty? (string=? "" path))) - (map (lambda (extension) (if empty? extension (string-join (list path "/" extension) ""))) - (filter (cute glob-match pattern <>) - (map car (cddr (file-system-tree (if empty? (getcwd) path)))))))) + (map (lambda (extension) (if empty? extension (string-join (list path "/" extension) ""))) + (filter (cute glob-match pattern <>) + (map car (cddr (file-system-tree (if empty? (getcwd) path)))))))) paths)) - (let ((absolute? (eq? #\/ (string-ref pattern 0)))) - (let loop ((patterns (string-split pattern #\/)) - (paths (if absolute? '("/") `("")))) - (if (null? patterns) paths - (loop (cdr patterns) (glob- (car patterns) paths)))))) + (if (glob? pattern) + (let ((absolute? (char=? #\/ (string-ref pattern 0)))) + (let loop ((patterns (string-split pattern #\/)) + (paths (if absolute? '("/") `("")))) + (if (null? patterns) paths + (loop (cdr patterns) (glob- (car patterns) paths))))) + (list pattern))) -(define (builtin . ast) +(define (builtin ast) + ;(stdout "builtin: " ast) (match ast (("cd" arg) `(chdir ,arg)) - (_ `(apply system* ,(cons 'list ast))))) + (('for-each rest ...) ast) + (('if rest ...) ast) + (_ #f))) + + +;; TODO: add globbing (define (transform ast) (match ast - (('script command ...) (cons 'list (map transform command))) + (('script command ...) (map transform command)) (('script command separator) (transform command)) (('if-clause "if" (expression "then" consequent "fi")) `(if (equal? 0 (status:exit-val ,(transform expression))) ,(transform consequent))) (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) `(if (equal? 0 (status:exit-val ,(transform expression))) ,(transform consequent) ,(transform alternative))) - (('for-clause "for" ((identifier "in" lst sep) do-group)) (list 'for-each (list 'lambda (list (string->symbol identifier)) (expand identifier (transform do-group))) (cons 'list (transform (glob lst))))) + (('for-clause "for" ((identifier "in" lst sep) do-group)) `(for-each (lambda (,(string->symbol identifier)) ,(expand identifier (transform do-group))) (glob ,(transform lst)))) (('do-group "do" (command "done")) (transform command)) - (('pipeline command) (let ((command (transform command))) (if (eq? 'list (car command)) `(apply system* ,command) command))) - (('pipeline command piped-commands) (cons 'pipeline (cons (transform command) (transform piped-commands)))) + (('pipeline command) (let* ((command (transform command))) (or (builtin command) `(pipeline ,command)))) + (('pipeline command piped-commands) `(pipeline ,(transform command) ,@(transform piped-commands))) (('simple-command ('word s)) `(list ,(transform s))) - (('simple-command ('word s1) ('word s2)) (apply builtin (append (list (transform s1)) (glob (transform s2))))) - (('simple-command ('word s1) (('word s2) ...)) (apply builtin (append (list (transform s1)) (map transform s2)))) + (('simple-command ('word s1) ('word s2)) `(append (glob ,(transform s1)) (glob ,(transform s2)))) + (('simple-command ('word s1) (('word s2) ...)) `(append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2))))) (('literal s) (transform s)) (('singlequotes s) (string-concatenate (list "'" s "'"))) (('doublequotes s) (string-concatenate (list "\"" s "\""))) @@ -164,20 +177,19 @@ copyleft. (('delim ('backticks s ...)) (string-concatenate (map transform s))) ((('pipe _) command ...) (map transform command)) (((('pipe _) command) ...) (map transform command)) - ((_ o) (transform o)) ;;peel the onion: (symbol (...)) -> (...) + ((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...) (_ ast))) (define (sh-exec ast) ;; (local-eval (transform ast) (the-environment)) (define (exec cmd) + ;(format (current-output-port) "eval: ~s\n" cmd) (local-eval cmd (the-environment))) - ;;(stdout "parsed: " ast) + ;(format (current-error-port) "parsed: ~a\n" ast) (let ((cmd (transform ast))) - ;;(stdout "executing: " cmd) (match cmd ('script '()) ;; skip - (('list cmd ...) (map exec cmd)) - (_ (exec cmd))))) + ((? list? cmd ...) (map exec cmd))))) (define (prompt) (let* ((esc (string #\033)) diff --git a/sh/pipe.scm b/sh/pipe.scm index 61e5dd4..e27d37d 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -50,6 +50,7 @@ (commands (cdr commands))) (if (null? (cdr commands)) (spawn-sink src (car commands)) (loop (spawn-filter src (car commands)) - (cdr commands)))))) + (cdr commands)))) + (apply system* (car commands)))) ;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) diff --git a/test/ls b/test/ls index 9e2740c..0b5dbb1 100644 --- a/test/ls +++ b/test/ls @@ -1 +1 @@ -ls +ls * diff --git a/test/pipe b/test/pipe index b1aa416..9055090 100644 --- a/test/pipe +++ b/test/pipe @@ -1 +1 @@ -echo -e 'a\nb\nc' | grep -v b | cat +echo -e 'a\nb\nc' * | sed 's, ,\n,g' | cat From cd6133a468498b4a7367ee918d0e112d8735b36d Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Thu, 13 Oct 2016 23:40:44 +0200 Subject: [PATCH 030/312] implement multiple terms --- sh/anguish.scm | 22 ++++++++++++++-------- test.sh | 2 +- 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 3b5a4e4..80f64f8 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -157,15 +157,18 @@ copyleft. (define (transform ast) (match ast - (('script command ...) (map transform command)) - (('script command separator) (transform command)) + (('script terms ...) (list (transform terms))) + (('script term separator) (transform term)) (('if-clause "if" (expression "then" consequent "fi")) `(if (equal? 0 (status:exit-val ,(transform expression))) ,(transform consequent))) (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) `(if (equal? 0 (status:exit-val ,(transform expression))) ,(transform consequent) ,(transform alternative))) (('for-clause "for" ((identifier "in" lst sep) do-group)) `(for-each (lambda (,(string->symbol identifier)) ,(expand identifier (transform do-group))) (glob ,(transform lst)))) (('do-group "do" (command "done")) (transform command)) (('pipeline command) (let* ((command (transform command))) (or (builtin command) `(pipeline ,command)))) (('pipeline command piped-commands) `(pipeline ,(transform command) ,@(transform piped-commands))) - (('simple-command ('word s)) `(list ,(transform s))) + (('compound-list terms ...) (transform terms)) + ((('term command)) (transform command)) + ((('term ('pipeline command)) (('term ('pipeline commands)) ...)) `(map pipeline ,(cons 'list (cons (transform command) (map transform commands))))) + (('simple-command ('word s)) `(glob ,(transform s))) (('simple-command ('word s1) ('word s2)) `(append (glob ,(transform s1)) (glob ,(transform s2)))) (('simple-command ('word s1) (('word s2) ...)) `(append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2))))) (('literal s) (transform s)) @@ -180,16 +183,19 @@ copyleft. ((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...) (_ ast))) -(define (sh-exec ast) ;; (local-eval (transform ast) (the-environment)) +(define (sh-exec ast) (define (exec cmd) ;(format (current-output-port) "eval: ~s\n" cmd) (local-eval cmd (the-environment))) - ;(format (current-error-port) "parsed: ~a\n" ast) - (let ((cmd (transform ast))) - (match cmd + (let* (;(print (format (current-error-port) "parsed: ~a\n" ast)) + (ast (transform ast)) + ;(print (format (current-error-port) "transformed: ~a\n" ast)) + ) + (match ast ('script '()) ;; skip - ((? list? cmd ...) (map exec cmd))))) + (_ (map exec ast))))) + (define (prompt) (let* ((esc (string #\033)) diff --git a/test.sh b/test.sh index a7098d7..07cfe2b 100644 --- a/test.sh +++ b/test.sh @@ -1 +1 @@ -for f in *; do ../anguish -p $f; done +for f in test/*; do echo $f; ./anguish -p $f; ./anguish $f; done From 3431779da221d975adc72fabf4e98b51e47e6ac9 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Fri, 14 Oct 2016 22:58:11 +0200 Subject: [PATCH 031/312] split tests --- test.sh | 2 +- test/ifthenelse | 1 + test/list | 1 + {test => todo}/case | 0 {test => todo}/iohere | 0 {test => todo}/test | 0 6 files changed, 3 insertions(+), 1 deletion(-) create mode 100644 test/ifthenelse create mode 100644 test/list rename {test => todo}/case (100%) rename {test => todo}/iohere (100%) rename {test => todo}/test (100%) diff --git a/test.sh b/test.sh index 07cfe2b..09c545b 100644 --- a/test.sh +++ b/test.sh @@ -1 +1 @@ -for f in test/*; do echo $f; ./anguish -p $f; ./anguish $f; done +for f in test/*; do echo $f; ./anguish $f; done diff --git a/test/ifthenelse b/test/ifthenelse new file mode 100644 index 0000000..38e5a8c --- /dev/null +++ b/test/ifthenelse @@ -0,0 +1 @@ +if test -e TOD; then echo exists; else echo "nope it don't"; fi diff --git a/test/list b/test/list new file mode 100644 index 0000000..7951df4 --- /dev/null +++ b/test/list @@ -0,0 +1 @@ +echo *e*a*;echo *r?p*;echo *;echo [a-l]*[m-z]*; echo; diff --git a/test/case b/todo/case similarity index 100% rename from test/case rename to todo/case diff --git a/test/iohere b/todo/iohere similarity index 100% rename from test/iohere rename to todo/iohere diff --git a/test/test b/todo/test similarity index 100% rename from test/test rename to todo/test From 68767152ec0de23376c816f62e9ea32aa63445c9 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sun, 16 Oct 2016 00:03:45 +0200 Subject: [PATCH 032/312] jobcontrol WIP --- sh/pipe.scm | 89 +++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 87 insertions(+), 2 deletions(-) diff --git a/sh/pipe.scm b/sh/pipe.scm index e27d37d..930477d 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -1,16 +1,19 @@ (define-module (sh pipe) :use-module (ice-9 popen) + :use-module (srfi srfi-1) :use-module (srfi srfi-8) + :use-module (srfi srfi-9) + :use-module (srfi srfi-26) :export (pipeline)) (define (pipe*) (let ((p (pipe))) (values (car p) (cdr p)))) -;; lhs rhs +;; lhs rhs ;; [source] w -> r [filter] w -> r [sink] -(define (exec* command) +(define (exec* command) ;; list of strings (apply execlp (cons (car command) command))) (define (spawn-source command) @@ -53,4 +56,86 @@ (cdr commands)))) (apply system* (car commands)))) +;;(pipeline (list "ls" "/") ;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (stdout . o) + (map display o) + (newline)) + +(define (stderr . o) + (map (cut display <> (current-error-port)) o) + (newline)) + +(define-record-type + (make-job id pid pgid command status ) + job? + (id job-id) + (pid job-pid) + (pgid job-pgid) + (command job-command) + (status job-status set-job-status!)) ;; '(running stopped completed terminated) + +(define job-table '()) + +(define (job-control-init) + (let* ((interactive? (isatty? (current-input-port))) + (pid (getpid)) + (pgid pid)) + (when interactive? + (map (cut sigaction <> SIG_IGN) + (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) + (setpgid pid pgid) + (tcsetpgrp (current-input-port) pid)))) + +(define (job-launch command fg?) + (let* ((interactive? (isatty? (current-input-port))) + (pgid (getpid)) + (pid (primitive-fork))) + (if (= 0 pid) + (when interactive? + (setpgid pid pgid) + (if fg? (tcsetpgrp (current-input-port) pgid)) + (map (cut sigaction <> SIG_DFL) + (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) + (map move->fdes + (list (current-input-port) (current-output-port) (current-error-port)) + (iota 4)) + (exec* command) + (exit 1)) + (when interactive? + (setpgid pid pgid) + (set! job-table + (acons pid + (make-job (length job-table) pid pgid command 'running) + job-table)) + (when fg? + (waitpid pid WUNTRACED) + (tcsetpgrp (current-input-port) (getpid))))))) + +(define (set-job-stopped! job-table pid) + (set-job-status! (assoc-ref job-table pid) 'stopped)) + +(define (update-job-status job-table) + (let* ((pid-status (waitpid WAIT_ANY (logior WUNTRACED WNOHANG))) + (pid (car pid-status)) + (status (cdr pid-status))) + (if (and (not (= 0 pid)) + (status:stop-sig status)) + (set-job-stopped! pid job-table)))) + +;(define (handle-children sig)) + +(define (background job-id) + (let ((job (if (< job-id (length job-table)) (list-ref job-table job-id) #f))) + (if (and job (eq? 'stopped job-status)) + (kill (- (job-pgid job)) SIGCONT)))) + +;; (define (foreground job) +;; ()) + +;; (init) + +;; (launch (list "sleep" "10") #t) From a2595bef0fca8a8f6dbcb125e15f9a6c94a1c9ed Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sun, 16 Oct 2016 12:49:07 +0200 Subject: [PATCH 033/312] checkpoint --- sh/pipe.scm | 45 ++++++++++++++++++++++++++++++++------------- 1 file changed, 32 insertions(+), 13 deletions(-) diff --git a/sh/pipe.scm b/sh/pipe.scm index 930477d..b98c46c 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -118,24 +118,43 @@ (define (set-job-stopped! job-table pid) (set-job-status! (assoc-ref job-table pid) 'stopped)) -(define (update-job-status job-table) +(define (set-job-terminated! job-table pid) ;; signal + (set-job-status! (assoc-ref job-table pid) 'terminated)) + +(define (set-job-completed! job-table pid) ;; exit value + (set-job-status! (assoc-ref job-table pid) 'completed)) + +(define (mark-status pid status) + (if (not (= 0 pid)) + (cond ((status:stop-sig status) + (set-job-stopped! pid job-table)) + ((status:term-sig status) + (set-job-terminated! pid job-table)) + ((status:exit-val status) + (set-job-completed! pid job-table))))) + +(define (notify-job-status job-table) ;; call when prompting, from SIGCHLD handler or (let* ((pid-status (waitpid WAIT_ANY (logior WUNTRACED WNOHANG))) (pid (car pid-status)) (status (cdr pid-status))) - (if (and (not (= 0 pid)) - (status:stop-sig status)) - (set-job-stopped! pid job-table)))) + (mark-status pid status))) -;(define (handle-children sig)) +(define (job-by-id job-table id) + (if (< job-id (length job-table)) + (list-ref job-table job-id) + #f)) (define (background job-id) - (let ((job (if (< job-id (length job-table)) (list-ref job-table job-id) #f))) - (if (and job (eq? 'stopped job-status)) + (let ((job (job-by-id job-table job-id))) + (if (and job (eq? 'stopped (job-status job))) (kill (- (job-pgid job)) SIGCONT)))) -;; (define (foreground job) -;; ()) - -;; (init) - -;; (launch (list "sleep" "10") #t) +(define (foreground job-id) + (let ((job (job-by-id job-table job-id))) + (tcsetpgrp (current-input-port) (job-pgid job)) + (if (and job (eq? 'stopped (job-status job))) + (kill (- (job-pgid job)) SIGCONT)) + (let ((pid-status (waitpid WAIT_ANY WUNTRACED)) ;; loop until job-id changes status + (pid (car pid-status)) + (status (cdr pid-status))) + (mark-process pid status)))) From 31a19a6e22260d01f7a2144ddd1125b695eb7be0 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Mon, 17 Oct 2016 09:29:13 +0200 Subject: [PATCH 034/312] checkpoint --- sh/pipe.scm | 37 ++++++++++++++++++++++--------------- 1 file changed, 22 insertions(+), 15 deletions(-) diff --git a/sh/pipe.scm b/sh/pipe.scm index b98c46c..0be4a6b 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -90,7 +90,7 @@ (setpgid pid pgid) (tcsetpgrp (current-input-port) pid)))) -(define (job-launch command fg?) +(define (job-launch command fg?) ;; todo: integrate into pipeline (let* ((interactive? (isatty? (current-input-port))) (pgid (getpid)) (pid (primitive-fork))) @@ -115,6 +115,24 @@ (waitpid pid WUNTRACED) (tcsetpgrp (current-input-port) (getpid))))))) +(define (mark-job-status pid status) + (if (not (= 0 pid)) + (cond ((status:stop-sig status) + (set-job-stopped! pid job-table)) + ((status:term-sig status) + (set-job-terminated! pid job-table)) + ((status:exit-val status) + (set-job-completed! pid job-table))))) + +(define (job-wait job) + (let loop () + (let* ((status (job-status job)) + (pid-status (waitpid WAIT_ANY WUNTRACED)) + (pid (car pid-status)) + (status (cdr pid-status))) + (mark-job-status pid status) + (if (eq? status (job-status job)) (loop))))) + (define (set-job-stopped! job-table pid) (set-job-status! (assoc-ref job-table pid) 'stopped)) @@ -124,20 +142,11 @@ (define (set-job-completed! job-table pid) ;; exit value (set-job-status! (assoc-ref job-table pid) 'completed)) -(define (mark-status pid status) - (if (not (= 0 pid)) - (cond ((status:stop-sig status) - (set-job-stopped! pid job-table)) - ((status:term-sig status) - (set-job-terminated! pid job-table)) - ((status:exit-val status) - (set-job-completed! pid job-table))))) - (define (notify-job-status job-table) ;; call when prompting, from SIGCHLD handler or (let* ((pid-status (waitpid WAIT_ANY (logior WUNTRACED WNOHANG))) (pid (car pid-status)) (status (cdr pid-status))) - (mark-status pid status))) + (mark-job-status pid status))) (define (job-by-id job-table id) (if (< job-id (length job-table)) @@ -154,7 +163,5 @@ (tcsetpgrp (current-input-port) (job-pgid job)) (if (and job (eq? 'stopped (job-status job))) (kill (- (job-pgid job)) SIGCONT)) - (let ((pid-status (waitpid WAIT_ANY WUNTRACED)) ;; loop until job-id changes status - (pid (car pid-status)) - (status (cdr pid-status))) - (mark-process pid status)))) + (job-wait job) + (tcsetpgrp (current-input-port) (getpid)))) From 975d3f7ee0f034afed9264493473f6968db74838 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Tue, 18 Oct 2016 09:15:53 +0200 Subject: [PATCH 035/312] checkpoint: HAX0R kuch!!! 8-( --- sh/anguish.scm | 12 +-- sh/pipe.scm | 259 ++++++++++++++++++++++++++++--------------------- 2 files changed, 156 insertions(+), 115 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 80f64f8..8a23e52 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -35,6 +35,7 @@ ((compose string-to-ast file-to-string) filename)) (define (main args) + (job-control-init) (let* ((option-spec '((debug (single-char #\d) (value #f)) (help (single-char #\h) (value #f)) (parse (single-char #\p) (value #f)) @@ -49,11 +50,10 @@ (cond (parse? (let ((ast- (transform ast))) (format (current-output-port) "parsed : ~s\n\n" ast) - (format (current-output-port) "prepared: ~s\n\n" ast-) + (map (cut format (current-output-port) "prepared: ~s\n\n" <>) ast-) #t)) (#t - (sh-exec ast) - #t)))))) + (sh-exec ast))))))) (cond (help? (display "\ @@ -181,7 +181,7 @@ copyleft. ((('pipe _) command ...) (map transform command)) (((('pipe _) command) ...) (map transform command)) ((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...) - (_ ast))) + (_ ast))) ;; done (define (sh-exec ast) (define (exec cmd) @@ -193,8 +193,8 @@ copyleft. ;(print (format (current-error-port) "transformed: ~a\n" ast)) ) (match ast - ('script '()) ;; skip - (_ (map exec ast))))) + ('script #t) ;; skip + (_ (begin (map exec ast) #t))))) (define (prompt) diff --git a/sh/pipe.scm b/sh/pipe.scm index 0be4a6b..19eebf1 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -4,7 +4,61 @@ :use-module (srfi srfi-8) :use-module (srfi srfi-9) :use-module (srfi srfi-26) - :export (pipeline)) + :export (pipeline job-control-init)) + +(define (stdout . o) + (map display o) + (newline)) + +(define (stderr . o) + (map (cut display <> (current-error-port)) o) + (newline)) + +(define-record-type + (make-process pid command status) + process? + (pid process-pid) + (command process-command) + (status process-status set-process-status!)) ;; '(running stopped completed terminated) + +(define-record-type + (make-job id pgid processes) + job? + (id job-id) + (pgid job-pgid set-job-pgid!) + (processes job-processes set-job-processes!)) + +(define job-table '()) ;; list of + +;; (define (job-at index) +;; (let ((len (length job-table))) +;; (if (or (> index len) (< index 0)) #f +;; (list-ref job-table (- len index))))) + +(define (add-to-process-group job pid) + (let* ((pgid (job-pgid job)) + (pgid (if (= 0 pgid) pid pgid))) + (setpgid pid pgid) + pgid)) + +(define (job-add-process job pid command) + (let ((pgid (add-to-process-group job pid))) + (set-job-pgid! job pgid) + (tcsetpgrp (current-input-port) pgid) + (cons (make-process pid command 'running) (job-processes job)))) + +(define (job-control-init) + (let* ((interactive? (isatty? (current-input-port))) + (pgid (getpgrp)) + (pid (getpid))) + (when interactive? + (while (not (eqv? (tcgetpgrp (current-input-port)) pgid)) + (kill (- pgid) SIGTTIN)) ;; we are not in the foreground + (map (cut sigaction <> SIG_IGN) + (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU)) + (sigaction SIGCHLD SIG_DFL) + (setpgid pid pid) ;; create new process group for ourself + (tcsetpgrp (current-input-port) pid)))) (define (pipe*) (let ((p (pipe))) @@ -16,152 +70,139 @@ (define (exec* command) ;; list of strings (apply execlp (cons (car command) command))) -(define (spawn-source command) +(define (spawn-source job interactive? command) (receive (r w) (pipe*) (let ((pid (primitive-fork))) (cond ((= 0 pid) (close r) + (tcsetpgrp (current-input-port) (add-to-process-group job (getpid))) (move->fdes w 1) (exec* command)) (#t + (job-add-process job pid command) (close w) r))))) -(define (spawn-filter src command) +(define (spawn-filter job interactive? src command) (receive (r w) (pipe*) (let ((pid (primitive-fork))) (cond ((= 0 pid) + (tcsetpgrp (current-input-port) (add-to-process-group job (getpid))) (move->fdes src 0) (close r) (move->fdes w 1) (exec* command)) (#t + (job-add-process job pid command) (close w) r))))) -(define (spawn-sink src command) +(define (spawn-sink job interactive? src command) (let ((pid (primitive-fork))) (cond ((= 0 pid) - (move->fdes src 0) + (tcsetpgrp (current-input-port) (add-to-process-group job (getpid))) + (map (cut sigaction <> SIG_DFL) + (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) + + (and src (move->fdes src 0)) (exec* command)) (#t - (close src) - (waitpid pid))))) + (job-add-process job pid command) + (and src (close src)))))) (define (pipeline . commands) - (if (< 1 (length commands)) - (let loop ((src (spawn-source (car commands))) - (commands (cdr commands))) - (if (null? (cdr commands)) (spawn-sink src (car commands)) - (loop (spawn-filter src (car commands)) - (cdr commands)))) - (apply system* (car commands)))) + (let ((interactive? (isatty? (current-input-port))) + (job (make-job (length job-table) 0 '()))) + (set! job-table (cons job job-table)) + (if (< 1 (length commands)) + (let loop ((src (spawn-source job interactive? (car commands))) + (commands (cdr commands))) + (if (null? (cdr commands)) + (spawn-sink job interactive? src (car commands)) + (loop (spawn-filter job interactive? src (car commands)) + (cdr commands)))) + (spawn-sink job interactive? #f (car commands)))) + (waitpid WAIT_ANY WUNTRACED) + (sleep 2) + ;;(tcsetpgrp (current-input-port) (getpgrp)) + (stdout "job-table: " job-table)) ;;(pipeline (list "ls" "/") ;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (stdout . o) - (map display o) - (newline)) +;; (define (job-launch command fg?) ;; todo: integrate into pipeline +;; (let* ((interactive? (isatty? (current-input-port))) +;; (pgid (getpid)) +;; (pid (primitive-fork))) +;; (if (= 0 pid) +;; (when interactive? ;; the child i.e. command +;; (setpgid pid pgid) +;; (if fg? (tcsetpgrp (current-input-port) pgid)) +;; (map (cut sigaction <> SIG_DFL) +;; (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) +;; (map move->fdes +;; (list (current-input-port) (current-output-port) (current-error-port)) +;; (iota 4)) +;; (exec* command) +;; (exit 1)) +;; (when interactive? ;; the parent i.e. shell +;; (setpgid pid pgid) +;; (set! job-table +;; (acons pid +;; (make-job (length job-table) `(,pid) pgid command 'running) +;; job-table)) +;; (when fg? +;; (waitpid pid WUNTRACED) +;; (tcsetpgrp (current-input-port) (getpid))))))) -(define (stderr . o) - (map (cut display <> (current-error-port)) o) - (newline)) +;; (define (mark-job-status pid status) +;; (if (not (= 0 pid)) +;; (cond ((status:stop-sig status) +;; (set-job-stopped! pid job-table)) +;; ((status:term-sig status) +;; (set-job-terminated! pid job-table)) +;; ((status:exit-val status) +;; (set-job-completed! pid job-table))))) -(define-record-type - (make-job id pid pgid command status ) - job? - (id job-id) - (pid job-pid) - (pgid job-pgid) - (command job-command) - (status job-status set-job-status!)) ;; '(running stopped completed terminated) +;; (define (job-wait job) +;; (let loop () +;; (let* ((status (job-status job)) +;; (pid-status (waitpid WAIT_ANY WUNTRACED)) +;; (pid (car pid-status)) +;; (status (cdr pid-status))) +;; (mark-job-status pid status) +;; (if (eq? status (job-status job)) (loop))))) -(define job-table '()) +;; (define (set-job-stopped! job-table pid) +;; (set-job-status! (assoc-ref job-table pid) 'stopped)) -(define (job-control-init) - (let* ((interactive? (isatty? (current-input-port))) - (pid (getpid)) - (pgid pid)) - (when interactive? - (map (cut sigaction <> SIG_IGN) - (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) - (setpgid pid pgid) - (tcsetpgrp (current-input-port) pid)))) +;; (define (set-job-terminated! job-table pid) ;; signal +;; (set-job-status! (assoc-ref job-table pid) 'terminated)) -(define (job-launch command fg?) ;; todo: integrate into pipeline - (let* ((interactive? (isatty? (current-input-port))) - (pgid (getpid)) - (pid (primitive-fork))) - (if (= 0 pid) - (when interactive? - (setpgid pid pgid) - (if fg? (tcsetpgrp (current-input-port) pgid)) - (map (cut sigaction <> SIG_DFL) - (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) - (map move->fdes - (list (current-input-port) (current-output-port) (current-error-port)) - (iota 4)) - (exec* command) - (exit 1)) - (when interactive? - (setpgid pid pgid) - (set! job-table - (acons pid - (make-job (length job-table) pid pgid command 'running) - job-table)) - (when fg? - (waitpid pid WUNTRACED) - (tcsetpgrp (current-input-port) (getpid))))))) +;; (define (set-job-completed! job-table pid) ;; exit value +;; (set-job-status! (assoc-ref job-table pid) 'completed)) -(define (mark-job-status pid status) - (if (not (= 0 pid)) - (cond ((status:stop-sig status) - (set-job-stopped! pid job-table)) - ((status:term-sig status) - (set-job-terminated! pid job-table)) - ((status:exit-val status) - (set-job-completed! pid job-table))))) +;; (define (notify-job-status job-table) ;; call when prompting, from SIGCHLD handler or +;; (let* ((pid-status (waitpid WAIT_ANY (logior WUNTRACED WNOHANG))) +;; (pid (car pid-status)) +;; (status (cdr pid-status))) +;; (mark-job-status pid status))) -(define (job-wait job) - (let loop () - (let* ((status (job-status job)) - (pid-status (waitpid WAIT_ANY WUNTRACED)) - (pid (car pid-status)) - (status (cdr pid-status))) - (mark-job-status pid status) - (if (eq? status (job-status job)) (loop))))) +;; (define (job-by-id job-table id) +;; (if (< job-id (length job-table)) +;; (list-ref job-table job-id) +;; #f)) -(define (set-job-stopped! job-table pid) - (set-job-status! (assoc-ref job-table pid) 'stopped)) +;; (define (background job-id) +;; (let ((job (job-by-id job-table job-id))) +;; (if (and job (eq? 'stopped (job-status job))) +;; (kill (- (job-pgid job)) SIGCONT)))) -(define (set-job-terminated! job-table pid) ;; signal - (set-job-status! (assoc-ref job-table pid) 'terminated)) - -(define (set-job-completed! job-table pid) ;; exit value - (set-job-status! (assoc-ref job-table pid) 'completed)) - -(define (notify-job-status job-table) ;; call when prompting, from SIGCHLD handler or - (let* ((pid-status (waitpid WAIT_ANY (logior WUNTRACED WNOHANG))) - (pid (car pid-status)) - (status (cdr pid-status))) - (mark-job-status pid status))) - -(define (job-by-id job-table id) - (if (< job-id (length job-table)) - (list-ref job-table job-id) - #f)) - -(define (background job-id) - (let ((job (job-by-id job-table job-id))) - (if (and job (eq? 'stopped (job-status job))) - (kill (- (job-pgid job)) SIGCONT)))) - -(define (foreground job-id) - (let ((job (job-by-id job-table job-id))) - (tcsetpgrp (current-input-port) (job-pgid job)) - (if (and job (eq? 'stopped (job-status job))) - (kill (- (job-pgid job)) SIGCONT)) - (job-wait job) - (tcsetpgrp (current-input-port) (getpid)))) +;; (define (foreground job-id) +;; (let ((job (job-by-id job-table job-id))) +;; (tcsetpgrp (current-input-port) (job-pgid job)) +;; (if (and job (eq? 'stopped (job-status job))) +;; (kill (- (job-pgid job)) SIGCONT)) +;; (job-wait job) +;; (tcsetpgrp (current-input-port) (getpid)))) From 23e8fba9fb3652e8dd12422c67279da5c1e447a9 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Tue, 18 Oct 2016 23:11:31 +0200 Subject: [PATCH 036/312] checkpoint: tcsetpgrp works when using current-error-port i.s.o. current-input-port or current-output-port (they are attached to readline-port) --- sh/anguish.scm | 3 +- sh/pipe.scm | 85 ++++++++++++++++++++++++++------------------------ 2 files changed, 46 insertions(+), 42 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 8a23e52..6e4b864 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -36,6 +36,7 @@ (define (main args) (job-control-init) + (stdout "ISATTY: " (isatty? (current-input-port))) (let* ((option-spec '((debug (single-char #\d) (value #f)) (help (single-char #\h) (value #f)) (parse (single-char #\p) (value #f)) @@ -204,7 +205,7 @@ copyleft. (cwd (if (string-prefix? HOME CWD) (string-replace CWD "~" 0 (string-length HOME)) CWD))) - (string-append esc "[01;34m" cwd esc "[00m$ "))) + (string-append (if (isatty? (current-error-port)) "OK" "NOK") esc "[01;34m" cwd esc "[00m$ "))) (define (redraw-current-line) (dynamic-call (dynamic-func "rl_refresh_line" diff --git a/sh/pipe.scm b/sh/pipe.scm index 19eebf1..3cacec7 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -37,28 +37,28 @@ (define (add-to-process-group job pid) (let* ((pgid (job-pgid job)) - (pgid (if (= 0 pgid) pid pgid))) + (pgid (or pgid pid))) (setpgid pid pgid) pgid)) (define (job-add-process job pid command) (let ((pgid (add-to-process-group job pid))) (set-job-pgid! job pgid) - (tcsetpgrp (current-input-port) pgid) - (cons (make-process pid command 'running) (job-processes job)))) + (tcsetpgrp (current-error-port) pgid) + (set-job-processes! job (cons (make-process pid command 'running) (job-processes job))))) (define (job-control-init) - (let* ((interactive? (isatty? (current-input-port))) + (let* ((interactive? (isatty? (current-error-port))) (pgid (getpgrp)) (pid (getpid))) (when interactive? - (while (not (eqv? (tcgetpgrp (current-input-port)) pgid)) + (while (not (eqv? (tcgetpgrp (current-error-port)) pgid)) (kill (- pgid) SIGTTIN)) ;; we are not in the foreground (map (cut sigaction <> SIG_IGN) (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU)) (sigaction SIGCHLD SIG_DFL) (setpgid pid pid) ;; create new process group for ourself - (tcsetpgrp (current-input-port) pid)))) + (tcsetpgrp (current-error-port) pid)))) (define (pipe*) (let ((p (pipe))) @@ -74,7 +74,7 @@ (receive (r w) (pipe*) (let ((pid (primitive-fork))) (cond ((= 0 pid) (close r) - (tcsetpgrp (current-input-port) (add-to-process-group job (getpid))) + (tcsetpgrp (current-error-port) (add-to-process-group job (getpid))) (move->fdes w 1) (exec* command)) (#t @@ -86,7 +86,7 @@ (receive (r w) (pipe*) (let ((pid (primitive-fork))) (cond ((= 0 pid) - (tcsetpgrp (current-input-port) (add-to-process-group job (getpid))) + (tcsetpgrp (current-error-port) (add-to-process-group job (getpid))) (move->fdes src 0) (close r) (move->fdes w 1) @@ -99,7 +99,8 @@ (define (spawn-sink job interactive? src command) (let ((pid (primitive-fork))) (cond ((= 0 pid) - (tcsetpgrp (current-input-port) (add-to-process-group job (getpid))) + (tcsetpgrp (current-error-port) (add-to-process-group job (getpid))) + (map (cut sigaction <> SIG_DFL) (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) @@ -109,11 +110,39 @@ (job-add-process job pid command) (and src (close src)))))) +(define (job-launch command fg?) ;; todo: integrate into pipeline + (let* ((interactive? (isatty? (current-error-port))) + (foo (stdout "ISATTY: " interactive?)) + (pgid (getpid)) + (pid (primitive-fork))) + (if (= 0 pid) + (when interactive? ;; the child i.e. command + (setpgid (getpid) (getpid)) ;; put job in own process group + (if fg? (tcsetpgrp (current-error-port) (getpid))) ;; put job in foreground + + (map (cut sigaction <> SIG_DFL) + (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) + (fdes->inport 0) + (map fdes->outport '(1 2)) + + (exec* command) + (exit 1)) + (when interactive? ;; the parent i.e. shell + (setpgid pid pid) ;; put job in own process group + (tcsetpgrp (current-error-port) pid) ;; put job in foreground + (when fg? + (waitpid pid WUNTRACED) + (tcsetpgrp (current-error-port) (getpid))))))) ;; put shell in foreground + +(define (pipelinex . commands) + (stdout "pipeline: " commands) + (job-launch (car commands) #t)) + (define (pipeline . commands) - (let ((interactive? (isatty? (current-input-port))) - (job (make-job (length job-table) 0 '()))) + (let ((interactive? (isatty? (current-error-port))) + (job (make-job (length job-table) #f '()))) (set! job-table (cons job job-table)) - (if (< 1 (length commands)) + (if (> (length commands) 1) (let loop ((src (spawn-source job interactive? (car commands))) (commands (cdr commands))) (if (null? (cdr commands)) @@ -122,8 +151,7 @@ (cdr commands)))) (spawn-sink job interactive? #f (car commands)))) (waitpid WAIT_ANY WUNTRACED) - (sleep 2) - ;;(tcsetpgrp (current-input-port) (getpgrp)) + (tcsetpgrp (current-error-port) (getpgrp)) (stdout "job-table: " job-table)) ;;(pipeline (list "ls" "/") @@ -131,31 +159,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (define (job-launch command fg?) ;; todo: integrate into pipeline -;; (let* ((interactive? (isatty? (current-input-port))) -;; (pgid (getpid)) -;; (pid (primitive-fork))) -;; (if (= 0 pid) -;; (when interactive? ;; the child i.e. command -;; (setpgid pid pgid) -;; (if fg? (tcsetpgrp (current-input-port) pgid)) -;; (map (cut sigaction <> SIG_DFL) -;; (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) -;; (map move->fdes -;; (list (current-input-port) (current-output-port) (current-error-port)) -;; (iota 4)) -;; (exec* command) -;; (exit 1)) -;; (when interactive? ;; the parent i.e. shell -;; (setpgid pid pgid) -;; (set! job-table -;; (acons pid -;; (make-job (length job-table) `(,pid) pgid command 'running) -;; job-table)) -;; (when fg? -;; (waitpid pid WUNTRACED) -;; (tcsetpgrp (current-input-port) (getpid))))))) - ;; (define (mark-job-status pid status) ;; (if (not (= 0 pid)) ;; (cond ((status:stop-sig status) @@ -201,8 +204,8 @@ ;; (define (foreground job-id) ;; (let ((job (job-by-id job-table job-id))) -;; (tcsetpgrp (current-input-port) (job-pgid job)) +;; (tcsetpgrp (current-error-port) (job-pgid job)) ;; (if (and job (eq? 'stopped (job-status job))) ;; (kill (- (job-pgid job)) SIGCONT)) ;; (job-wait job) -;; (tcsetpgrp (current-input-port) (getpid)))) +;; (tcsetpgrp (current-error-port) (getpid)))) From d595a401b94250f637865ba9bbcc70f1eb508783 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 19 Oct 2016 00:01:02 +0200 Subject: [PATCH 037/312] checkpoint --- sh/anguish.scm | 7 ++- sh/pipe.scm | 116 +++++++++++++++++++++++++++++++------------------ 2 files changed, 76 insertions(+), 47 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 6e4b864..4a4641f 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -36,7 +36,6 @@ (define (main args) (job-control-init) - (stdout "ISATTY: " (isatty? (current-input-port))) (let* ((option-spec '((debug (single-char #\d) (value #f)) (help (single-char #\h) (value #f)) (parse (single-char #\p) (value #f)) @@ -146,9 +145,9 @@ copyleft. (define (builtin ast) - ;(stdout "builtin: " ast) + (format (current-error-port) "builtin: ~s\n" ast) (match ast - (("cd" arg) `(chdir ,arg)) + (('append ('glob "cd") arg) `(apply chdir ,arg)) (('for-each rest ...) ast) (('if rest ...) ast) (_ #f))) @@ -205,7 +204,7 @@ copyleft. (cwd (if (string-prefix? HOME CWD) (string-replace CWD "~" 0 (string-length HOME)) CWD))) - (string-append (if (isatty? (current-error-port)) "OK" "NOK") esc "[01;34m" cwd esc "[00m$ "))) + (string-append esc "[01;34m" cwd esc "[00m$ "))) (define (redraw-current-line) (dynamic-call (dynamic-func "rl_refresh_line" diff --git a/sh/pipe.scm b/sh/pipe.scm index 3cacec7..ec15b89 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -1,9 +1,13 @@ (define-module (sh pipe) + :use-module (ice-9 popen) + :use-module (ice-9 pretty-print) + :use-module (srfi srfi-1) :use-module (srfi srfi-8) :use-module (srfi srfi-9) :use-module (srfi srfi-26) + :export (pipeline job-control-init)) (define (stdout . o) @@ -15,11 +19,12 @@ (newline)) (define-record-type - (make-process pid command status) + (make-process pid command status state) process? (pid process-pid) (command process-command) - (status process-status set-process-status!)) ;; '(running stopped completed terminated) + (status process-status set-process-status!) + (state process-state set-process-state!)) ;; '(running stopped completed terminated) (define-record-type (make-job id pgid processes) @@ -30,6 +35,26 @@ (define job-table '()) ;; list of +(define (status->state status) + (cond ((status:exit-val status) + 'completed) + ((status:term-sig status) + 'terminated) + ((status:stop-sig status) + 'stopped))) + +(define (job-status job) + (process-status (car (job-processes job)))) + +(define (job-update job pid status) + (unless (= 0 pid) + (let ((proc (find (compose (cute eqv? pid <>) process-pid) (job-processes job)))) + (set-process-status! proc status) + (set-process-state! proc (status->state status))))) + +(define (job-running? job) + (find (compose (cute eq? 'running <>) process-state) (job-processes job))) + ;; (define (job-at index) ;; (let ((len (length job-table))) ;; (if (or (> index len) (< index 0)) #f @@ -45,7 +70,7 @@ (let ((pgid (add-to-process-group job pid))) (set-job-pgid! job pgid) (tcsetpgrp (current-error-port) pgid) - (set-job-processes! job (cons (make-process pid command 'running) (job-processes job))))) + (set-job-processes! job (cons (make-process pid command #f 'running) (job-processes job))))) (define (job-control-init) (let* ((interactive? (isatty? (current-error-port))) @@ -53,7 +78,7 @@ (pid (getpid))) (when interactive? (while (not (eqv? (tcgetpgrp (current-error-port)) pgid)) - (kill (- pgid) SIGTTIN)) ;; we are not in the foreground + (kill (- pgid) SIGTTIN)) ;; oops we are not in the foreground (map (cut sigaction <> SIG_IGN) (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU)) (sigaction SIGCHLD SIG_DFL) @@ -70,11 +95,17 @@ (define (exec* command) ;; list of strings (apply execlp (cons (car command) command))) +(define (setup-process job) + (tcsetpgrp (current-error-port) (add-to-process-group job (getpid))) + (map (cut sigaction <> SIG_DFL) + (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) + (fdes->inport 0) (map fdes->outport '(1 2))) ;; reset stdin/stdout/stderr + (define (spawn-source job interactive? command) (receive (r w) (pipe*) (let ((pid (primitive-fork))) (cond ((= 0 pid) (close r) - (tcsetpgrp (current-error-port) (add-to-process-group job (getpid))) + (setup-process job) (move->fdes w 1) (exec* command)) (#t @@ -86,7 +117,7 @@ (receive (r w) (pipe*) (let ((pid (primitive-fork))) (cond ((= 0 pid) - (tcsetpgrp (current-error-port) (add-to-process-group job (getpid))) + (setup-process job) (move->fdes src 0) (close r) (move->fdes w 1) @@ -99,45 +130,13 @@ (define (spawn-sink job interactive? src command) (let ((pid (primitive-fork))) (cond ((= 0 pid) - (tcsetpgrp (current-error-port) (add-to-process-group job (getpid))) - - (map (cut sigaction <> SIG_DFL) - (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) - + (setup-process job) (and src (move->fdes src 0)) (exec* command)) (#t (job-add-process job pid command) (and src (close src)))))) -(define (job-launch command fg?) ;; todo: integrate into pipeline - (let* ((interactive? (isatty? (current-error-port))) - (foo (stdout "ISATTY: " interactive?)) - (pgid (getpid)) - (pid (primitive-fork))) - (if (= 0 pid) - (when interactive? ;; the child i.e. command - (setpgid (getpid) (getpid)) ;; put job in own process group - (if fg? (tcsetpgrp (current-error-port) (getpid))) ;; put job in foreground - - (map (cut sigaction <> SIG_DFL) - (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) - (fdes->inport 0) - (map fdes->outport '(1 2)) - - (exec* command) - (exit 1)) - (when interactive? ;; the parent i.e. shell - (setpgid pid pid) ;; put job in own process group - (tcsetpgrp (current-error-port) pid) ;; put job in foreground - (when fg? - (waitpid pid WUNTRACED) - (tcsetpgrp (current-error-port) (getpid))))))) ;; put shell in foreground - -(define (pipelinex . commands) - (stdout "pipeline: " commands) - (job-launch (car commands) #t)) - (define (pipeline . commands) (let ((interactive? (isatty? (current-error-port))) (job (make-job (length job-table) #f '()))) @@ -149,16 +148,47 @@ (spawn-sink job interactive? src (car commands)) (loop (spawn-filter job interactive? src (car commands)) (cdr commands)))) - (spawn-sink job interactive? #f (car commands)))) - (waitpid WAIT_ANY WUNTRACED) - (tcsetpgrp (current-error-port) (getpgrp)) - (stdout "job-table: " job-table)) + (spawn-sink job interactive? #f (car commands))) + (let loop () + (let* ((pid-status (waitpid WAIT_ANY WUNTRACED)) + (pid (car pid-status)) + (status (cdr pid-status))) + (job-update job pid status) + (if (job-running? job) (loop)))) + (tcsetpgrp (current-error-port) (getpid)) + (pretty-print job-table) + (job-status job))) ;;(pipeline (list "ls" "/") ;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (define (job-launch command fg?) ;; todo: integrate into pipeline +;; (let* ((interactive? (isatty? (current-error-port))) +;; (foo (stdout "ISATTY: " interactive?)) +;; (pgid (getpid)) +;; (pid (primitive-fork))) +;; (if (= 0 pid) +;; (when interactive? ;; the child i.e. command +;; (setpgid (getpid) (getpid)) ;; put job in own process group +;; (if fg? (tcsetpgrp (current-error-port) (getpid))) ;; put job in foreground + +;; (map (cut sigaction <> SIG_DFL) +;; (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) + +;; (fdes->inport 0) +;; (map fdes->outport '(1 2)) + +;; (exec* command) +;; (exit 1)) +;; (when interactive? ;; the parent i.e. shell +;; (setpgid pid pid) ;; put job in own process group +;; (tcsetpgrp (current-error-port) pid) ;; put job in foreground +;; (when fg? +;; (waitpid pid WUNTRACED) +;; (tcsetpgrp (current-error-port) (getpid))))))) ;; put shell in foreground + ;; (define (mark-job-status pid status) ;; (if (not (= 0 pid)) ;; (cond ((status:stop-sig status) From fee393aaddfe51f9a3fdedf05e270065bf5aa8a1 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 19 Oct 2016 00:53:14 +0200 Subject: [PATCH 038/312] cleanup --- sh/anguish.scm | 2 +- sh/pipe.scm | 107 +++++-------------------------------------------- 2 files changed, 11 insertions(+), 98 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 4a4641f..0d5789c 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -145,7 +145,7 @@ copyleft. (define (builtin ast) - (format (current-error-port) "builtin: ~s\n" ast) + ;;(format (current-error-port) "builtin: ~s\n" ast) (match ast (('append ('glob "cd") arg) `(apply chdir ,arg)) (('for-each rest ...) ast) diff --git a/sh/pipe.scm b/sh/pipe.scm index ec15b89..b19dd9a 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -19,12 +19,11 @@ (newline)) (define-record-type - (make-process pid command status state) + (make-process pid command status) process? (pid process-pid) (command process-command) - (status process-status set-process-status!) - (state process-state set-process-state!)) ;; '(running stopped completed terminated) + (status process-status set-process-status!)) (define-record-type (make-job id pgid processes) @@ -36,12 +35,10 @@ (define job-table '()) ;; list of (define (status->state status) - (cond ((status:exit-val status) - 'completed) - ((status:term-sig status) - 'terminated) - ((status:stop-sig status) - 'stopped))) + (cond ((status:exit-val status) 'completed) + ((status:term-sig status) 'terminated) + ((status:stop-sig status) 'stopped) + (#t 'running))) (define (job-status job) (process-status (car (job-processes job)))) @@ -49,16 +46,10 @@ (define (job-update job pid status) (unless (= 0 pid) (let ((proc (find (compose (cute eqv? pid <>) process-pid) (job-processes job)))) - (set-process-status! proc status) - (set-process-state! proc (status->state status))))) + (set-process-status! proc status)))) (define (job-running? job) - (find (compose (cute eq? 'running <>) process-state) (job-processes job))) - -;; (define (job-at index) -;; (let ((len (length job-table))) -;; (if (or (> index len) (< index 0)) #f -;; (list-ref job-table (- len index))))) + (find (compose not process-status) (job-processes job))) (define (add-to-process-group job pid) (let* ((pgid (job-pgid job)) @@ -70,7 +61,7 @@ (let ((pgid (add-to-process-group job pid))) (set-job-pgid! job pgid) (tcsetpgrp (current-error-port) pgid) - (set-job-processes! job (cons (make-process pid command #f 'running) (job-processes job))))) + (set-job-processes! job (cons (make-process pid command #f) (job-processes job))))) (define (job-control-init) (let* ((interactive? (isatty? (current-error-port))) @@ -156,86 +147,8 @@ (job-update job pid status) (if (job-running? job) (loop)))) (tcsetpgrp (current-error-port) (getpid)) - (pretty-print job-table) + ;;(pretty-print job-table) (job-status job))) ;;(pipeline (list "ls" "/") ;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; (define (job-launch command fg?) ;; todo: integrate into pipeline -;; (let* ((interactive? (isatty? (current-error-port))) -;; (foo (stdout "ISATTY: " interactive?)) -;; (pgid (getpid)) -;; (pid (primitive-fork))) -;; (if (= 0 pid) -;; (when interactive? ;; the child i.e. command -;; (setpgid (getpid) (getpid)) ;; put job in own process group -;; (if fg? (tcsetpgrp (current-error-port) (getpid))) ;; put job in foreground - -;; (map (cut sigaction <> SIG_DFL) -;; (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) - -;; (fdes->inport 0) -;; (map fdes->outport '(1 2)) - -;; (exec* command) -;; (exit 1)) -;; (when interactive? ;; the parent i.e. shell -;; (setpgid pid pid) ;; put job in own process group -;; (tcsetpgrp (current-error-port) pid) ;; put job in foreground -;; (when fg? -;; (waitpid pid WUNTRACED) -;; (tcsetpgrp (current-error-port) (getpid))))))) ;; put shell in foreground - -;; (define (mark-job-status pid status) -;; (if (not (= 0 pid)) -;; (cond ((status:stop-sig status) -;; (set-job-stopped! pid job-table)) -;; ((status:term-sig status) -;; (set-job-terminated! pid job-table)) -;; ((status:exit-val status) -;; (set-job-completed! pid job-table))))) - -;; (define (job-wait job) -;; (let loop () -;; (let* ((status (job-status job)) -;; (pid-status (waitpid WAIT_ANY WUNTRACED)) -;; (pid (car pid-status)) -;; (status (cdr pid-status))) -;; (mark-job-status pid status) -;; (if (eq? status (job-status job)) (loop))))) - -;; (define (set-job-stopped! job-table pid) -;; (set-job-status! (assoc-ref job-table pid) 'stopped)) - -;; (define (set-job-terminated! job-table pid) ;; signal -;; (set-job-status! (assoc-ref job-table pid) 'terminated)) - -;; (define (set-job-completed! job-table pid) ;; exit value -;; (set-job-status! (assoc-ref job-table pid) 'completed)) - -;; (define (notify-job-status job-table) ;; call when prompting, from SIGCHLD handler or -;; (let* ((pid-status (waitpid WAIT_ANY (logior WUNTRACED WNOHANG))) -;; (pid (car pid-status)) -;; (status (cdr pid-status))) -;; (mark-job-status pid status))) - -;; (define (job-by-id job-table id) -;; (if (< job-id (length job-table)) -;; (list-ref job-table job-id) -;; #f)) - -;; (define (background job-id) -;; (let ((job (job-by-id job-table job-id))) -;; (if (and job (eq? 'stopped (job-status job))) -;; (kill (- (job-pgid job)) SIGCONT)))) - -;; (define (foreground job-id) -;; (let ((job (job-by-id job-table job-id))) -;; (tcsetpgrp (current-error-port) (job-pgid job)) -;; (if (and job (eq? 'stopped (job-status job))) -;; (kill (- (job-pgid job)) SIGCONT)) -;; (job-wait job) -;; (tcsetpgrp (current-error-port) (getpid)))) From 4997c4421dfbaf25aac43dea88cb53d37a945ea9 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 19 Oct 2016 01:23:03 +0200 Subject: [PATCH 039/312] align globbing --- sh/anguish.scm | 2 +- test.sh => test-anguish.sh | 0 2 files changed, 1 insertion(+), 1 deletion(-) rename test.sh => test-anguish.sh (100%) diff --git a/sh/anguish.scm b/sh/anguish.scm index 0d5789c..723c0d0 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -132,7 +132,7 @@ copyleft. (let ((empty? (string=? "" path))) (map (lambda (extension) (if empty? extension (string-join (list path "/" extension) ""))) (filter (cute glob-match pattern <>) - (map car (cddr (file-system-tree (if empty? (getcwd) path)))))))) + (filter (negate (cute string-any #\. <> 0 1)) (scandir (if empty? (getcwd) path))))))) paths)) (if (glob? pattern) diff --git a/test.sh b/test-anguish.sh similarity index 100% rename from test.sh rename to test-anguish.sh From fb6a7d027903560f1f1c8b475ef110a3ddbae7a8 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 19 Oct 2016 14:26:06 +0200 Subject: [PATCH 040/312] replace file-system-tree with scandir --- sh/anguish.scm | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 723c0d0..7fbd719 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -213,9 +213,8 @@ copyleft. (define (filename-completion text state) (if (not state) - (let ((completions (map car - (filter (cute string-prefix? text <>) - (map car (cddr (file-system-tree (getcwd)))))))) + (let ((completions (filter (cute string-prefix? text <>) + (scandir (getcwd))))) (cond ((< 1 (length completions)) (begin (newline) (display (string-join completions " ")) (newline) (redraw-current-line) @@ -226,9 +225,8 @@ copyleft. (define (search-binary-in-path-completion text state) (if (not state) - (let ((completions (map car - (filter (cute string-prefix? text <>) - (map car (cddr (file-system-tree "/bin"))))))) + (let ((completions (filter (cute string-prefix? text <>) + (scandir "/bin")))) (cond ((< 1 (length completions)) (begin (newline) (display (string-join completions " ")) (newline) (redraw-current-line) @@ -239,5 +237,4 @@ copyleft. (define (completion text state) (or (filename-completion text state) - ;;(search-binary-in-path-completion text state) - )) + (search-binary-in-path-completion text state))) From fc8b856110a1eb9e9597953d759a858e7a1cd0a4 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 19 Oct 2016 22:18:13 +0200 Subject: [PATCH 041/312] make echo builtin --- sh/anguish.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/sh/anguish.scm b/sh/anguish.scm index 7fbd719..38ae94e 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -148,6 +148,7 @@ copyleft. ;;(format (current-error-port) "builtin: ~s\n" ast) (match ast (('append ('glob "cd") arg) `(apply chdir ,arg)) + (('append ('glob "echo") args ...) `(apply stdout ,@args)) (('for-each rest ...) ast) (('if rest ...) ast) (_ #f))) From 628f111ced3a9180d848c9ce51a01be3fc32bf31 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Thu, 20 Oct 2016 09:08:06 +0200 Subject: [PATCH 042/312] checkpoint --- sh/anguish.scm | 1 + sh/pipe.scm | 34 ++++++++++++++++++++++++++++------ 2 files changed, 29 insertions(+), 6 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 38ae94e..b127460 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -149,6 +149,7 @@ copyleft. (match ast (('append ('glob "cd") arg) `(apply chdir ,arg)) (('append ('glob "echo") args ...) `(apply stdout ,@args)) + (('glob "jobs") `(jobs)) (('for-each rest ...) ast) (('if rest ...) ast) (_ #f))) diff --git a/sh/pipe.scm b/sh/pipe.scm index b19dd9a..5c47121 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -8,7 +8,7 @@ :use-module (srfi srfi-9) :use-module (srfi srfi-26) - :export (pipeline job-control-init)) + :export (pipeline job-control-init jobs)) (define (stdout . o) (map display o) @@ -35,10 +35,17 @@ (define job-table '()) ;; list of (define (status->state status) - (cond ((status:exit-val status) 'completed) - ((status:term-sig status) 'terminated) - ((status:stop-sig status) 'stopped) - (#t 'running))) + (cond ((status:exit-val status) 'Completed) + ((status:term-sig status) 'Terminated) + ((status:stop-sig status) 'Stopped) + (#t 'Running))) + +(define (jobs) + (map (lambda (job number) + (stdout "[" number "]? " (status->state (job-status job)) "\t\t" + (process-command (car (job-processes job))))) + (reverse job-table) + (iota (length job-table) 1 1))) (define (job-status job) (process-status (car (job-processes job)))) @@ -51,6 +58,9 @@ (define (job-running? job) (find (compose not process-status) (job-processes job))) +(define (job-stopped? job) + (find (compose status:stop-sig process-status) (job-processes job))) + (define (add-to-process-group job pid) (let* ((pgid (job-pgid job)) (pgid (or pgid pid))) @@ -128,6 +138,10 @@ (job-add-process job pid command) (and src (close src)))))) +;; TODO: +;; report job status: before prompt or by calling jobs +;; remove reported terminated or completed jobs + (define (pipeline . commands) (let ((interactive? (isatty? (current-error-port))) (job (make-job (length job-table) #f '()))) @@ -148,7 +162,15 @@ (if (job-running? job) (loop)))) (tcsetpgrp (current-error-port) (getpid)) ;;(pretty-print job-table) - (job-status job))) + (job-status job) + (reap-jobs))) + +(define (disjoin . predicates) + (lambda (. arguments) + (any (cut apply <> arguments) predicates))) + +(define (reap-jobs) + (set! job-table (filter (disjoin job-running? job-stopped?) job-table))) ;;(pipeline (list "ls" "/") ;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) From 5c724a023a00d3bb3ff266085fac063ba293800f Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 26 Oct 2016 00:45:12 +0200 Subject: [PATCH 043/312] checkpoint: fg --- sh/anguish.scm | 2 ++ sh/pipe.scm | 45 ++++++++++++++++++++++++++++++++------------- 2 files changed, 34 insertions(+), 13 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index b127460..7ca79b0 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -148,7 +148,9 @@ copyleft. ;;(format (current-error-port) "builtin: ~s\n" ast) (match ast (('append ('glob "cd") arg) `(apply chdir ,arg)) + (('append ('glob "fg") ('glob arg)) `(fg ,(string->number arg))) (('append ('glob "echo") args ...) `(apply stdout ,@args)) + (('glob "fg") `(fg 1)) (('glob "jobs") `(jobs)) (('for-each rest ...) ast) (('if rest ...) ast) diff --git a/sh/pipe.scm b/sh/pipe.scm index 5c47121..b2c95a4 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -8,7 +8,7 @@ :use-module (srfi srfi-9) :use-module (srfi srfi-26) - :export (pipeline job-control-init jobs)) + :export (pipeline job-control-init jobs fg)) (define (stdout . o) (map display o) @@ -34,6 +34,12 @@ (define job-table '()) ;; list of +(define (job-index index) + (let ((index (- (length job-table) index))) + (if (<= 0 index) + (list-ref job-table index) + #f))) + (define (status->state status) (cond ((status:exit-val status) 'Completed) ((status:term-sig status) 'Terminated) @@ -143,8 +149,9 @@ ;; remove reported terminated or completed jobs (define (pipeline . commands) - (let ((interactive? (isatty? (current-error-port))) - (job (make-job (length job-table) #f '()))) + (let* ((interactive? (isatty? (current-error-port))) + (index (+ 1 (length job-table))) + (job (make-job index #f '()))) (set! job-table (cons job job-table)) (if (> (length commands) 1) (let loop ((src (spawn-source job interactive? (car commands))) @@ -154,16 +161,7 @@ (loop (spawn-filter job interactive? src (car commands)) (cdr commands)))) (spawn-sink job interactive? #f (car commands))) - (let loop () - (let* ((pid-status (waitpid WAIT_ANY WUNTRACED)) - (pid (car pid-status)) - (status (cdr pid-status))) - (job-update job pid status) - (if (job-running? job) (loop)))) - (tcsetpgrp (current-error-port) (getpid)) - ;;(pretty-print job-table) - (job-status job) - (reap-jobs))) + (wait job))) (define (disjoin . predicates) (lambda (. arguments) @@ -172,5 +170,26 @@ (define (reap-jobs) (set! job-table (filter (disjoin job-running? job-stopped?) job-table))) +(define (wait job) + (let ((index (job-id job))) + (let loop () + (let* ((pid-status (waitpid WAIT_ANY WUNTRACED)) + (pid (car pid-status)) + (status (cdr pid-status))) + (job-update job pid status) + (if (job-running? job) (loop)))) + (tcsetpgrp (current-error-port) (getpid)) + (stdout "\n[" index "] " (status->state (job-status job)) "\t\t" (string-join (append-map process-command (job-processes job)))) + (reap-jobs))) + +(define (fg index) + (let ((job (job-index index))) + (cond (job + (tcsetpgrp (current-error-port) (job-pgid job)) + (kill (- (job-pgid job)) SIGCONT) + (wait job)) + (#t + (stderr "fg: no such job " index))))) + ;;(pipeline (list "ls" "/") ;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) From ffebd76c5be16249b786d91a20c4409b844f5276 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 26 Oct 2016 23:56:26 +0200 Subject: [PATCH 044/312] checkpoint: bg --- sh/anguish.scm | 3 ++- sh/pipe.scm | 26 +++++++++++++++++--------- 2 files changed, 19 insertions(+), 10 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 7ca79b0..29d4ada 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -89,7 +89,6 @@ copyleft. (clear-history) (read-history HOME) (with-readline-completion-function completion thunk) - ;;(thunk) (write-history HOME)) (newline))))) @@ -149,8 +148,10 @@ copyleft. (match ast (('append ('glob "cd") arg) `(apply chdir ,arg)) (('append ('glob "fg") ('glob arg)) `(fg ,(string->number arg))) + (('append ('glob "bg") ('glob arg)) `(bg ,(string->number arg))) (('append ('glob "echo") args ...) `(apply stdout ,@args)) (('glob "fg") `(fg 1)) + (('glob "bg") `(bg 1)) (('glob "jobs") `(jobs)) (('for-each rest ...) ast) (('if rest ...) ast) diff --git a/sh/pipe.scm b/sh/pipe.scm index b2c95a4..0457d58 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -8,7 +8,7 @@ :use-module (srfi srfi-9) :use-module (srfi srfi-26) - :export (pipeline job-control-init jobs fg)) + :export (pipeline job-control-init jobs fg bg)) (define (stdout . o) (map display o) @@ -41,15 +41,18 @@ #f))) (define (status->state status) - (cond ((status:exit-val status) 'Completed) + (cond ((not status) 'Running) + ((status:exit-val status) 'Completed) ((status:term-sig status) 'Terminated) - ((status:stop-sig status) 'Stopped) - (#t 'Running))) + ((status:stop-sig status) 'Stopped))) + +(define (display-job job index) + (stdout "[" index "] " (status->state (job-status job)) "\t\t" + (string-join (append-map process-command (job-processes job))))) (define (jobs) - (map (lambda (job number) - (stdout "[" number "]? " (status->state (job-status job)) "\t\t" - (process-command (car (job-processes job))))) + (map (lambda (job index) + (display-job job index)) (reverse job-table) (iota (length job-table) 1 1))) @@ -58,7 +61,7 @@ (define (job-update job pid status) (unless (= 0 pid) - (let ((proc (find (compose (cute eqv? pid <>) process-pid) (job-processes job)))) + (let ((proc (find (compose (cut eqv? pid <>) process-pid) (job-processes job)))) (set-process-status! proc status)))) (define (job-running? job) @@ -179,7 +182,7 @@ (job-update job pid status) (if (job-running? job) (loop)))) (tcsetpgrp (current-error-port) (getpid)) - (stdout "\n[" index "] " (status->state (job-status job)) "\t\t" (string-join (append-map process-command (job-processes job)))) + (display-job job index) (reap-jobs))) (define (fg index) @@ -191,5 +194,10 @@ (#t (stderr "fg: no such job " index))))) +(define (bg index) + (let ((job (job-index index))) + (kill (- (job-pgid job)) SIGCONT) + (map (cut set-process-status! <> #f) (job-processes job)))) + ;;(pipeline (list "ls" "/") ;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) From ff41fce5ba607781d53baf9dbe8b422997b85718 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sat, 29 Oct 2016 15:30:39 +0200 Subject: [PATCH 045/312] checkpoint --- anguish | 2 +- sh/anguish.scm | 6 ++-- sh/peg.scm | 11 ++++---- sh/pipe.scm | 74 ++++++++++++++++++++++++++++++-------------------- 4 files changed, 54 insertions(+), 39 deletions(-) diff --git a/anguish b/anguish index bdbce94..a59d3c4 100755 --- a/anguish +++ b/anguish @@ -1,4 +1,4 @@ -#!/usr/bin/guile-2.2 \ +#!/usr/bin/guile \ --debug -e main -s !# ;; workaround: diff --git a/sh/anguish.scm b/sh/anguish.scm index 29d4ada..66da80b 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -82,7 +82,8 @@ copyleft. (if (not (eof-object? line)) (begin (let ((ast (string-to-ast line))) - (add-history line) + (if (not (string-null? line)) + (add-history line)) (run ast)) (loop (readline (prompt))))))))) (activate-readline) @@ -158,8 +159,6 @@ copyleft. (_ #f))) -;; TODO: add globbing - (define (transform ast) (match ast (('script terms ...) (list (transform terms))) @@ -209,6 +208,7 @@ copyleft. (cwd (if (string-prefix? HOME CWD) (string-replace CWD "~" 0 (string-length HOME)) CWD))) + (report-jobs) (string-append esc "[01;34m" cwd esc "[00m$ "))) (define (redraw-current-line) diff --git a/sh/peg.scm b/sh/peg.scm index b345ad6..63b4de7 100644 --- a/sh/peg.scm +++ b/sh/peg.scm @@ -14,12 +14,11 @@ (define (parse input) (let ((tree (parse- input))) - (and tree - (cond ((error? tree) - (format (current-error-port) "error: ~a\n" tree) - #f) - (#t - tree))))) + (cond ((error? tree) + (format (current-error-port) "error: ~a\n" tree) + #f) + (#t + tree)))) (define (parse- input) (define label "") diff --git a/sh/pipe.scm b/sh/pipe.scm index 0457d58..acc8b86 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -8,7 +8,7 @@ :use-module (srfi srfi-9) :use-module (srfi srfi-26) - :export (pipeline job-control-init jobs fg bg)) + :export (pipeline job-control-init jobs report-jobs fg bg)) (define (stdout . o) (map display o) @@ -42,33 +42,40 @@ (define (status->state status) (cond ((not status) 'Running) - ((status:exit-val status) 'Completed) + ((status:exit-val status) 'Done) ((status:term-sig status) 'Terminated) ((status:stop-sig status) 'Stopped))) -(define (display-job job index) - (stdout "[" index "] " (status->state (job-status job)) "\t\t" - (string-join (append-map process-command (job-processes job))))) +(define (job-command job) + (string-join (map (compose string-join process-command) (reverse (job-processes job))) " | ")) + +(define (display-job job) + (stdout "[" (job-id job) "] " (status->state (job-status job)) "\t\t" + (job-command job))) (define (jobs) - (map (lambda (job index) - (display-job job index)) - (reverse job-table) - (iota (length job-table) 1 1))) + (map (lambda (job) + (display-job job)) + (reverse job-table))) (define (job-status job) - (process-status (car (job-processes job)))) + (process-status (last (job-processes job)))) (define (job-update job pid status) (unless (= 0 pid) (let ((proc (find (compose (cut eqv? pid <>) process-pid) (job-processes job)))) - (set-process-status! proc status)))) + (when proc + (set-process-status! proc status))))) (define (job-running? job) (find (compose not process-status) (job-processes job))) (define (job-stopped? job) - (find (compose status:stop-sig process-status) (job-processes job))) + (find status:stop-sig (filter-map process-status (job-processes job)))) + +(define (job-completed? job) + (let ((state (map (compose status->state process-status) (job-processes job)))) + (every (cut member <> '(Done Terminated)) state))) (define (add-to-process-group job pid) (let* ((pgid (job-pgid job)) @@ -147,15 +154,11 @@ (job-add-process job pid command) (and src (close src)))))) -;; TODO: -;; report job status: before prompt or by calling jobs -;; remove reported terminated or completed jobs (define (pipeline . commands) (let* ((interactive? (isatty? (current-error-port))) (index (+ 1 (length job-table))) (job (make-job index #f '()))) - (set! job-table (cons job job-table)) (if (> (length commands) 1) (let loop ((src (spawn-source job interactive? (car commands))) (commands (cdr commands))) @@ -164,40 +167,53 @@ (loop (spawn-filter job interactive? src (car commands)) (cdr commands)))) (spawn-sink job interactive? #f (car commands))) + (set! job-table (cons job job-table)) (wait job))) (define (disjoin . predicates) (lambda (. arguments) - (any (cut apply <> arguments) predicates))) + (any (cut apply <> arguments) predicates))) (define (reap-jobs) (set! job-table (filter (disjoin job-running? job-stopped?) job-table))) +(define (report-jobs) + (when (not (null? job-table)) + (let* ((pid-status (waitpid WAIT_ANY (logior WUNTRACED WNOHANG))) + (pid (car pid-status)) + (status (cdr pid-status))) + (unless (= 0 pid) + (map (cut job-update <> pid status) job-table) + (map display-job (filter job-completed? job-table)) + (reap-jobs))))) + (define (wait job) - (let ((index (job-id job))) - (let loop () - (let* ((pid-status (waitpid WAIT_ANY WUNTRACED)) - (pid (car pid-status)) - (status (cdr pid-status))) - (job-update job pid status) - (if (job-running? job) (loop)))) - (tcsetpgrp (current-error-port) (getpid)) - (display-job job index) - (reap-jobs))) + (let loop () + (let* ((pid-status (waitpid (- (job-pgid job)) WUNTRACED)) + (pid (car pid-status)) + (status (cdr pid-status))) + (job-update job pid status) + (if (job-running? job) (loop)))) + (tcsetpgrp (current-error-port) (getpid)) + (unless (job-completed? job) + (newline) (display-job job)) + (reap-jobs) + (job-status job)) (define (fg index) (let ((job (job-index index))) (cond (job (tcsetpgrp (current-error-port) (job-pgid job)) (kill (- (job-pgid job)) SIGCONT) + (stdout (job-command job)) (wait job)) (#t (stderr "fg: no such job " index))))) (define (bg index) (let ((job (job-index index))) - (kill (- (job-pgid job)) SIGCONT) - (map (cut set-process-status! <> #f) (job-processes job)))) + (map (cut set-process-status! <> #f) (job-processes job)) + (kill (- (job-pgid job)) SIGCONT))) ;;(pipeline (list "ls" "/") ;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) From 1b31587c9b91de99968b3992ae63474af0f0d756 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Mon, 31 Oct 2016 00:19:44 +0100 Subject: [PATCH 046/312] checkpoint --- sh/anguish.scm | 39 +++++++++++++++++++++++++-------------- sh/peg.scm | 6 +++--- test/ifthen | 2 +- 3 files changed, 29 insertions(+), 18 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 66da80b..14ef88c 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -17,7 +17,8 @@ (define (stdout . o) (map (lambda (o) (display o (current-output-port))) o) - (newline) + (newline (current-output-port)) + (force-output (current-output-port)) o) (define (stderr . o) @@ -50,7 +51,8 @@ (cond (parse? (let ((ast- (transform ast))) (format (current-output-port) "parsed : ~s\n\n" ast) - (map (cut format (current-output-port) "prepared: ~s\n\n" <>) ast-) + (format (current-output-port) "prepared : ~s\n\n" ast-) + ;(map (cut format (current-output-port) "prepared: ~s\n\n" <>) ast-) #t)) (#t (sh-exec ast))))))) @@ -150,7 +152,8 @@ copyleft. (('append ('glob "cd") arg) `(apply chdir ,arg)) (('append ('glob "fg") ('glob arg)) `(fg ,(string->number arg))) (('append ('glob "bg") ('glob arg)) `(bg ,(string->number arg))) - (('append ('glob "echo") args ...) `(apply stdout ,@args)) + (('append ('glob "echo") args ...) `(stdout (string-join ,@args " "))) + (('glob "echo") `(stdout)) (('glob "fg") `(fg 1)) (('glob "bg") `(bg 1)) (('glob "jobs") `(jobs)) @@ -158,20 +161,29 @@ copyleft. (('if rest ...) ast) (_ #f))) +;; transform ast -> list of expr +;; such that (map eval expr) + +;; (define (background ast) +;; (match ast +;; (('pipeline fg rest ...) `(pipeline #f ,@rest)) +;; (_ ast))) (define (transform ast) (match ast - (('script terms ...) (list (transform terms))) - (('script term separator) (transform term)) - (('if-clause "if" (expression "then" consequent "fi")) `(if (equal? 0 (status:exit-val ,(transform expression))) ,(transform consequent))) - (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) `(if (equal? 0 (status:exit-val ,(transform expression))) ,(transform consequent) ,(transform alternative))) - (('for-clause "for" ((identifier "in" lst sep) do-group)) `(for-each (lambda (,(string->symbol identifier)) ,(expand identifier (transform do-group))) (glob ,(transform lst)))) + ;(('script term "&") (background (transform term))) + (('script term) (list (transform term))) + (('script terms ...) (transform terms)) + ((('term command)) (list (transform command))) + ((('term command) ...) (map transform command)) + ((('term command) (('term commands) ...)) (map transform (cons command commands))) + (('compound-list terms ...) (transform terms)) + (('if-clause "if" (expression "then" consequent "fi")) `(if (equal? 0 (status:exit-val (begin ,@(transform expression)))) (begin ,@(transform consequent)))) + (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) `(if (equal? 0 (status:exit-val ,@(transform expression))) (begin ,@(transform consequent)) (begin ,@(transform alternative)))) + (('for-clause "for" ((identifier "in" lst sep) do-group)) `(for-each (lambda (,(string->symbol identifier)) (begin ,@(expand identifier (transform do-group)))) (glob ,(transform lst)))) (('do-group "do" (command "done")) (transform command)) (('pipeline command) (let* ((command (transform command))) (or (builtin command) `(pipeline ,command)))) (('pipeline command piped-commands) `(pipeline ,(transform command) ,@(transform piped-commands))) - (('compound-list terms ...) (transform terms)) - ((('term command)) (transform command)) - ((('term ('pipeline command)) (('term ('pipeline commands)) ...)) `(map pipeline ,(cons 'list (cons (transform command) (map transform commands))))) (('simple-command ('word s)) `(glob ,(transform s))) (('simple-command ('word s1) ('word s2)) `(append (glob ,(transform s1)) (glob ,(transform s2)))) (('simple-command ('word s1) (('word s2) ...)) `(append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2))))) @@ -189,12 +201,11 @@ copyleft. (define (sh-exec ast) (define (exec cmd) - ;(format (current-output-port) "eval: ~s\n" cmd) (local-eval cmd (the-environment))) - (let* (;(print (format (current-error-port) "parsed: ~a\n" ast)) + (let* (;(print (format (current-error-port) "parsed: ~s\n" ast)) (ast (transform ast)) - ;(print (format (current-error-port) "transformed: ~a\n" ast)) + ;(print (format (current-error-port) "transformed: ~s\n" ast)) ) (match ast ('script #t) ;; skip diff --git a/sh/peg.scm b/sh/peg.scm index 63b4de7..c32d96d 100644 --- a/sh/peg.scm +++ b/sh/peg.scm @@ -90,10 +90,10 @@ singlequotes <-- sq ((doublequotes / backticks / (!sq .))* sq) doublequotes <-- dq ((singlequotes / backticks / (!dq .))* dq) backticks <-- bt ((singlequotes / doublequotes / (!bt .))* bt) - separator < (sp* break ws*) / ws+ - break <-- amp / semi !semi + separator <- (sp* break ws*) / ws+ + break <- amp / semi !semi sequential-sep <-- (semi !semi ws*) / ws+ - amp < '&' + amp <- '&' semi < ';' nl < '\n' sp < [\t ] diff --git a/test/ifthen b/test/ifthen index 5d36280..b70af03 100644 --- a/test/ifthen +++ b/test/ifthen @@ -1 +1 @@ -if test -e TODO; then echo exists; fi +if test -e TODO; then echo exists; echo I think; fi From 1837431f0cf989bfb259bd94c544ce829064a0c5 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Tue, 1 Nov 2016 11:25:36 +0100 Subject: [PATCH 047/312] background via "&" --- sh/anguish.scm | 21 +++++++++------------ sh/pipe.scm | 48 ++++++++++++++++++++++++------------------------ 2 files changed, 33 insertions(+), 36 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 14ef88c..bf56bad 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -52,7 +52,6 @@ (let ((ast- (transform ast))) (format (current-output-port) "parsed : ~s\n\n" ast) (format (current-output-port) "prepared : ~s\n\n" ast-) - ;(map (cut format (current-output-port) "prepared: ~s\n\n" <>) ast-) #t)) (#t (sh-exec ast))))))) @@ -88,7 +87,6 @@ copyleft. (add-history line)) (run ast)) (loop (readline (prompt))))))))) - (activate-readline) (clear-history) (read-history HOME) (with-readline-completion-function completion thunk) @@ -114,7 +112,7 @@ copyleft. (map foo o)) -;; TODO: add braces and pattern ending with / +;; TODO: add braces (define (glob pattern) ;; pattern -> list of path (define (glob? pattern) @@ -161,17 +159,17 @@ copyleft. (('if rest ...) ast) (_ #f))) +(define (background ast) + (match ast + (('pipeline fg rest ...) `(pipeline #f ,@rest)) + (_ ast))) + ;; transform ast -> list of expr ;; such that (map eval expr) -;; (define (background ast) -;; (match ast -;; (('pipeline fg rest ...) `(pipeline #f ,@rest)) -;; (_ ast))) - (define (transform ast) (match ast - ;(('script term "&") (background (transform term))) + (('script term "&") (list (background (transform term)))) (('script term) (list (transform term))) (('script terms ...) (transform terms)) ((('term command)) (list (transform command))) @@ -182,8 +180,8 @@ copyleft. (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) `(if (equal? 0 (status:exit-val ,@(transform expression))) (begin ,@(transform consequent)) (begin ,@(transform alternative)))) (('for-clause "for" ((identifier "in" lst sep) do-group)) `(for-each (lambda (,(string->symbol identifier)) (begin ,@(expand identifier (transform do-group)))) (glob ,(transform lst)))) (('do-group "do" (command "done")) (transform command)) - (('pipeline command) (let* ((command (transform command))) (or (builtin command) `(pipeline ,command)))) - (('pipeline command piped-commands) `(pipeline ,(transform command) ,@(transform piped-commands))) + (('pipeline command) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,command)))) + (('pipeline command piped-commands) `(pipeline #t ,(transform command) ,@(transform piped-commands))) (('simple-command ('word s)) `(glob ,(transform s))) (('simple-command ('word s1) ('word s2)) `(append (glob ,(transform s1)) (glob ,(transform s2)))) (('simple-command ('word s1) (('word s2) ...)) `(append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2))))) @@ -202,7 +200,6 @@ copyleft. (define (sh-exec ast) (define (exec cmd) (local-eval cmd (the-environment))) - (let* (;(print (format (current-error-port) "parsed: ~s\n" ast)) (ast (transform ast)) ;(print (format (current-error-port) "transformed: ~s\n" ast)) diff --git a/sh/pipe.scm b/sh/pipe.scm index acc8b86..1e1a6c4 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -83,10 +83,10 @@ (setpgid pid pgid) pgid)) -(define (job-add-process job pid command) +(define (job-add-process fg? job pid command) (let ((pgid (add-to-process-group job pid))) (set-job-pgid! job pgid) - (tcsetpgrp (current-error-port) pgid) + (if fg? (tcsetpgrp (current-error-port) pgid)) (set-job-processes! job (cons (make-process pid command #f) (job-processes job))))) (define (job-control-init) @@ -112,63 +112,63 @@ (define (exec* command) ;; list of strings (apply execlp (cons (car command) command))) -(define (setup-process job) - (tcsetpgrp (current-error-port) (add-to-process-group job (getpid))) - (map (cut sigaction <> SIG_DFL) - (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) +(define (setup-process fg? job) + (when (isatty? (current-error-port)) + (when fg? (tcsetpgrp (current-error-port) (add-to-process-group job (getpid)))) + (map (cut sigaction <> SIG_DFL) + (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD))) (fdes->inport 0) (map fdes->outport '(1 2))) ;; reset stdin/stdout/stderr -(define (spawn-source job interactive? command) +(define (spawn-source fg? job command) (receive (r w) (pipe*) (let ((pid (primitive-fork))) (cond ((= 0 pid) (close r) - (setup-process job) + (setup-process fg? job) (move->fdes w 1) (exec* command)) (#t - (job-add-process job pid command) + (job-add-process fg? job pid command) (close w) r))))) -(define (spawn-filter job interactive? src command) +(define (spawn-filter fg? job src command) (receive (r w) (pipe*) (let ((pid (primitive-fork))) (cond ((= 0 pid) - (setup-process job) + (setup-process fg? job) (move->fdes src 0) (close r) (move->fdes w 1) (exec* command)) (#t - (job-add-process job pid command) + (job-add-process fg? job pid command) (close w) r))))) -(define (spawn-sink job interactive? src command) +(define (spawn-sink fg? job src command) (let ((pid (primitive-fork))) (cond ((= 0 pid) - (setup-process job) - (and src (move->fdes src 0)) + (setup-process fg? job) + (if src (move->fdes src 0)) (exec* command)) (#t - (job-add-process job pid command) + (job-add-process fg? job pid command) (and src (close src)))))) -(define (pipeline . commands) - (let* ((interactive? (isatty? (current-error-port))) - (index (+ 1 (length job-table))) +(define (pipeline fg? . commands) + (let* ((index (+ 1 (length job-table))) (job (make-job index #f '()))) (if (> (length commands) 1) - (let loop ((src (spawn-source job interactive? (car commands))) + (let loop ((src (spawn-source fg? job (car commands))) (commands (cdr commands))) (if (null? (cdr commands)) - (spawn-sink job interactive? src (car commands)) - (loop (spawn-filter job interactive? src (car commands)) + (spawn-sink fg? job src (car commands)) + (loop (spawn-filter fg? job src (car commands)) (cdr commands)))) - (spawn-sink job interactive? #f (car commands))) + (spawn-sink fg? job #f (car commands))) (set! job-table (cons job job-table)) - (wait job))) + (if fg? (wait job)))) (define (disjoin . predicates) (lambda (. arguments) From d53f1055f35141e14ab697a1d8cfd49a45ef3cbe Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Tue, 1 Nov 2016 13:54:25 +0100 Subject: [PATCH 048/312] remove prompt coloring to allow readline to determine proper length --- sh/anguish.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index bf56bad..a6385f6 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -145,7 +145,6 @@ copyleft. (define (builtin ast) - ;;(format (current-error-port) "builtin: ~s\n" ast) (match ast (('append ('glob "cd") arg) `(apply chdir ,arg)) (('append ('glob "fg") ('glob arg)) `(fg ,(string->number arg))) @@ -208,6 +207,7 @@ copyleft. ('script #t) ;; skip (_ (begin (map exec ast) #t))))) +;;TODO add colors (define (prompt) (let* ((esc (string #\033)) @@ -217,7 +217,7 @@ copyleft. (string-replace CWD "~" 0 (string-length HOME)) CWD))) (report-jobs) - (string-append esc "[01;34m" cwd esc "[00m$ "))) + (string-append cwd "$ "))) (define (redraw-current-line) (dynamic-call (dynamic-func "rl_refresh_line" From d831a3ef24f63a4e840e27d4f986a512ce865263 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Tue, 1 Nov 2016 14:40:17 +0100 Subject: [PATCH 049/312] checkpoint --- sh/anguish.scm | 20 +++++++++++--------- test-anguish.sh | 1 + test-bash.sh | 2 ++ 3 files changed, 14 insertions(+), 9 deletions(-) mode change 100644 => 100755 test-anguish.sh create mode 100755 test-bash.sh diff --git a/sh/anguish.scm b/sh/anguish.scm index a6385f6..58b666d 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -103,13 +103,14 @@ copyleft. (string-split s #\newline)) "\n")) (define (expand identifier o) ;;identifier-string -> symbol - (define (foo o) + (define (expand- o) (let ((dollar-identifier (string-append "$" identifier))) (match o ((? symbol?) o) ((? string?) (if (string=? o dollar-identifier) (string->symbol identifier) o)) - ((? list?) (map foo o))))) - (map foo o)) + ((? list?) (map expand- o)) + (_ o)))) + (map expand- o)) ;; TODO: add braces @@ -119,10 +120,11 @@ copyleft. (string-match "\\?|\\*" pattern)) (define (glob2regex pattern) - (let* ((pattern (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post)) - (pattern (regexp-substitute/global #f "\\?" pattern 'pre "." 'post)) - (pattern (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post))) - (make-regexp (string-append pattern "$")))) + (let* ((regex (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post)) + (regex (regexp-substitute/global #f "\\?" pattern 'pre "." 'post)) + (regex (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post))) + (stdout "glob pattern: " pattern "regex pattern: " regex) + (make-regexp (string-append "^" regex "$")))) (define (glob-match pattern path) ;; pattern path -> bool (regexp-match? (regexp-exec (glob2regex pattern) path))) @@ -199,9 +201,9 @@ copyleft. (define (sh-exec ast) (define (exec cmd) (local-eval cmd (the-environment))) - (let* (;(print (format (current-error-port) "parsed: ~s\n" ast)) + (let* (;;(print (format (current-error-port) "parsed: ~s\n" ast)) (ast (transform ast)) - ;(print (format (current-error-port) "transformed: ~s\n" ast)) + ;;(print (format (current-error-port) "transformed: ~s\n" ast)) ) (match ast ('script #t) ;; skip diff --git a/test-anguish.sh b/test-anguish.sh old mode 100644 new mode 100755 index 09c545b..465b064 --- a/test-anguish.sh +++ b/test-anguish.sh @@ -1 +1,2 @@ +#!/bin/bash for f in test/*; do echo $f; ./anguish $f; done diff --git a/test-bash.sh b/test-bash.sh new file mode 100755 index 0000000..e16eb8d --- /dev/null +++ b/test-bash.sh @@ -0,0 +1,2 @@ +#!/bin/bash +for f in test/*; do echo $f; bash $f; done From 732ec746b8f3c8b4799347787a59d5d0f02ee548 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Tue, 1 Nov 2016 22:33:08 +0100 Subject: [PATCH 050/312] checkpoint: avoid redundant evals, color prompt, add profiling --- sh/anguish.scm | 131 ++++++++++++++++++++++++++----------------------- sh/pipe.scm | 2 +- 2 files changed, 71 insertions(+), 62 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 58b666d..6e2df64 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -1,4 +1,6 @@ (define-module (sh anguish) + :use-module (statprof) + :use-module (srfi srfi-1) :use-module (srfi srfi-26) :use-module (ice-9 ftw) @@ -36,35 +38,36 @@ ((compose string-to-ast file-to-string) filename)) (define (main args) - (job-control-init) - (let* ((option-spec '((debug (single-char #\d) (value #f)) - (help (single-char #\h) (value #f)) - (parse (single-char #\p) (value #f)) - (version (single-char #\v) (value #f)))) - (options (getopt-long args option-spec - #:stop-at-first-non-option #t )) - (help? (option-ref options 'help #f)) - (parse? (option-ref options 'parse (null? #f))) - (version? (option-ref options 'version #f)) - (files (option-ref options '() '())) - (run (lambda (ast) (and ast - (cond (parse? - (let ((ast- (transform ast))) - (format (current-output-port) "parsed : ~s\n\n" ast) - (format (current-output-port) "prepared : ~s\n\n" ast-) - #t)) - (#t - (sh-exec ast))))))) - (cond - (help? - (display "\ + (let ((thunk (lambda () + (job-control-init) + (let* ((option-spec '((debug (single-char #\d) (value #f)) + (help (single-char #\h) (value #f)) + (parse (single-char #\p) (value #f)) + (version (single-char #\v) (value #f)))) + (options (getopt-long args option-spec + #:stop-at-first-non-option #t )) + (help? (option-ref options 'help #f)) + (parse? (option-ref options 'parse (null? #f))) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '())) + (run (lambda (ast) (and ast + (cond (parse? + (let ((ast- (transform ast))) + (format (current-output-port) "parsed : ~s\n\n" ast) + (format (current-output-port) "prepared : ~s\n\n" ast-) + #t)) + (#t + (sh-exec ast))))))) + (cond + (help? + (display "\ anguish [options] -h, --help Display this help -p, --parse Parse the shell script and print the parse tree -v, --version Display the version ")) - (version? - (display " + (version? + (display " Anguish 0.1 Copryright (C) 2016 R.E.W. van Beusekom, rutger.van.beusekom@gmail.com. @@ -73,26 +76,27 @@ when your shell lacks a real programming language. Anguish is free software and is covered by the GNU Public License, see COPYING for the copyleft. ")) - ((pair? files) - (let* ((asts (map file-to-ast files)) - (status (map run asts))) - (quit (every identity status)))) - (#t (let* ((HOME (string-append (getenv "HOME") "/.anguishistory")) - (thunk (lambda () - (let loop ((line (readline (prompt)))) - (if (not (eof-object? line)) - (begin - (let ((ast (string-to-ast line))) - (if (not (string-null? line)) - (add-history line)) - (run ast)) - (loop (readline (prompt))))))))) - (clear-history) - (read-history HOME) - (with-readline-completion-function completion thunk) - (write-history HOME)) - (newline))))) - + ((pair? files) + (let* ((asts (map file-to-ast files)) + (status (map run asts))) + (quit (every identity status)))) + (#t (let* ((HOME (string-append (getenv "HOME") "/.anguishistory")) + (thunk (lambda () + (let loop ((line (readline (prompt)))) + (if (not (eof-object? line)) + (begin + (let ((ast (string-to-ast line))) + (if (not (string-null? line)) + (add-history line)) + (run ast)) + (loop (readline (prompt))))))))) + (clear-history) + (read-history HOME) + (with-readline-completion-function completion thunk) + (write-history HOME)) + (newline))))))) + ;;(statprof thunk #:hz 100 #:count-calls? #t) + (thunk))) (define (remove-shell-comments s) (string-join (map @@ -123,18 +127,17 @@ copyleft. (let* ((regex (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post)) (regex (regexp-substitute/global #f "\\?" pattern 'pre "." 'post)) (regex (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post))) - (stdout "glob pattern: " pattern "regex pattern: " regex) (make-regexp (string-append "^" regex "$")))) - (define (glob-match pattern path) ;; pattern path -> bool - (regexp-match? (regexp-exec (glob2regex pattern) path))) + (define (glob-match regex path) ;; pattern path -> bool + (regexp-match? (regexp-exec regex path))) (define (glob- pattern paths) (append-map (lambda (path) (let ((empty? (string=? "" path))) (map (lambda (extension) (if empty? extension (string-join (list path "/" extension) ""))) - (filter (cute glob-match pattern <>) - (filter (negate (cute string-any #\. <> 0 1)) (scandir (if empty? (getcwd) path))))))) + (filter (cute glob-match (glob2regex pattern) <>) + (filter (negate (cut string-any #\. <> 0 1)) (scandir (if empty? (getcwd) path))))))) paths)) (if (glob? pattern) @@ -209,17 +212,23 @@ copyleft. ('script #t) ;; skip (_ (begin (map exec ast) #t))))) -;;TODO add colors -(define (prompt) - (let* ((esc (string #\033)) - (CWD (getcwd)) - (HOME (getenv "HOME")) - (cwd (if (string-prefix? HOME CWD) - (string-replace CWD "~" 0 (string-length HOME)) - CWD))) - (report-jobs) - (string-append cwd "$ "))) +(define prompt + (let* ((l (string #\001)) + (r (string #\002)) + (e (string #\033)) + (user (getenv "USER")) + (host (gethostname)) + (home (getenv "HOME"))) + (lambda () + (let* ((cwd (getcwd)) + (cwd (if (string-prefix? home cwd) + (string-replace cwd "~" 0 (string-length home)) + cwd))) + (report-jobs) + (string-append + l e "[01;32m" r user "@" host l e "[00m" r ":" + l e "[01;34m" r cwd l e "[00m" r "$ "))))) (define (redraw-current-line) (dynamic-call (dynamic-func "rl_refresh_line" @@ -228,7 +237,7 @@ copyleft. (define (filename-completion text state) (if (not state) - (let ((completions (filter (cute string-prefix? text <>) + (let ((completions (filter (cut string-prefix? text <>) (scandir (getcwd))))) (cond ((< 1 (length completions)) (begin (newline) (display (string-join completions " ")) (newline) @@ -240,7 +249,7 @@ copyleft. (define (search-binary-in-path-completion text state) (if (not state) - (let ((completions (filter (cute string-prefix? text <>) + (let ((completions (filter (cut string-prefix? text <>) (scandir "/bin")))) (cond ((< 1 (length completions)) (begin (newline) (display (string-join completions " ")) (newline) diff --git a/sh/pipe.scm b/sh/pipe.scm index 1e1a6c4..e97c695 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -15,7 +15,7 @@ (newline)) (define (stderr . o) - (map (cut display <> (current-error-port)) o) + (map (cute display <> (current-error-port)) o) (newline)) (define-record-type From d4445ef21d15229978e85f49d1efe2d5374e319f Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 2 Nov 2016 14:13:31 +0100 Subject: [PATCH 051/312] fixed required trailing space --- sh/peg.scm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/sh/peg.scm b/sh/peg.scm index c32d96d..b1f9490 100644 --- a/sh/peg.scm +++ b/sh/peg.scm @@ -63,8 +63,9 @@ function-def <-- name sp* '(' sp* ')' ws* (function-body / error) function-body <-- compound-command io-redirect* brace-group <-- '{' (sp* (compound-list / error) sp* '}' / error) - simple-command <-- (io-redirect sp+)* !(reserved ws+) word (sp+ (io-redirect / (!(reserved ws+) word)))* + simple-command <-- (io-redirect sp+)* nonreserved (sp+ (io-redirect / nonreserved))* reserved < ('case' / 'esac' / 'if' / 'fi' / 'then' / 'else' / 'elif' / 'for' / 'done' / 'do' / 'until' / 'while') + nonreserved <- reserved word / !reserved word io-redirect <-- [0-9]* sp* (io-here / io-file) io-file <-- ('<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|') sp* ([0-9]+ / filename) io-here <- ('<<' / '<<-') io-suffix here-document @@ -73,7 +74,7 @@ filename <-- word name <-- identifier identifier <- [_a-zA-Z][_a-zA-Z0-9]* - word <-- test / substitution / assignment / literal / number + word <-- test / substitution / assignment / number / literal number <-- [0-9]+ test <-- ltest (!rtest .)* rtest ltest < '[ ' @@ -81,8 +82,8 @@ substitution <-- ('$(' (script ')' / error)) / ('`' (script '`' / error)) assignment <-- name assign word? assign < '=' - literal <-- (subst / delim / (![0-9] (![()] !io-op !sp !nl !break !pipe !assign .)+) / ([0-9]+ &separator)) literal* - subst <-- '$' ('$' / '*' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) + literal <-- (variable / delim / (![0-9] (![()] !io-op !sp !nl !break !pipe !assign .)+) / ([0-9]+ &separator)) literal* + variable <-- '$' ('$' / '*' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) delim <-- singlequotes / doublequotes / backticks sq < ['] dq < [\"] From 33131a6aed872c483cbf5a67780b3af6f2e3d17d Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 2 Nov 2016 21:53:08 +0100 Subject: [PATCH 052/312] completion --- sh/anguish.scm | 90 ++++++++++++++++++++++++++++++++++---------------- 1 file changed, 61 insertions(+), 29 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 6e2df64..36fd373 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -38,6 +38,7 @@ ((compose string-to-ast file-to-string) filename)) (define (main args) + (setenv "PATH" "/bin:/usr/bin:/sbin:/usr/sbin:.") (let ((thunk (lambda () (job-control-init) (let* ((option-spec '((debug (single-char #\d) (value #f)) @@ -230,35 +231,66 @@ copyleft. l e "[01;32m" r user "@" host l e "[00m" r ":" l e "[01;34m" r cwd l e "[00m" r "$ "))))) -(define (redraw-current-line) - (dynamic-call (dynamic-func "rl_refresh_line" - (dynamic-link "libreadline.so")) - #f)) +(define (string-prefix s1 s2) + (substring/read-only s1 0 (string-prefix-length s1 s2))) -(define (filename-completion text state) - (if (not state) - (let ((completions (filter (cut string-prefix? text <>) - (scandir (getcwd))))) - (cond ((< 1 (length completions)) (begin (newline) - (display (string-join completions " ")) (newline) - (redraw-current-line) - #f)) - ((= 1 (length completions)) (car completions)) - (#t #f))) - #f)) +(define next->file-completion (lambda () #f)) +(define next->binary-completion (lambda () #f)) -(define (search-binary-in-path-completion text state) - (if (not state) - (let ((completions (filter (cut string-prefix? text <>) - (scandir "/bin")))) - (cond ((< 1 (length completions)) (begin (newline) - (display (string-join completions " ")) (newline) - (redraw-current-line) - #f)) - ((= 1 (length completions)) (car completions)) - (#t #f))) - #f)) +(define (isdir? path) + (and (access? path F_OK) (eq? 'directory (stat:type (stat path))))) -(define (completion text state) - (or (filename-completion text state) - (search-binary-in-path-completion text state))) +(define (ls dir) + (map (lambda (path) + (if (isdir? (string-append dir path)) + (string-append path "/") + path)) + (sort (filter (negate (cut string-every #\. <>)) + (scandir (if (string-null? dir) (getcwd) dir))) string) list))) + +(define (slash dir) + (if (string-suffix? "/" dir) dir + (string-append dir "/"))) + +(define (after-slash path) + (let ((at (string-index-right path #\/))) + (if at (string-drop path (+ 1 at)) + path))) + + +(define (filename-completion text continue?) + (if continue? + (next->file-completion) + (let* ((dir (slash (if (isdir? text) text (dirname text)))) + (listing (ls dir)) + (dir (if (string=? "./" dir) "" dir)) + (completions (complete (after-slash text) listing))) + (set! next->file-completion + (lambda () + (if (null? completions) + #f + (let ((completion (car completions))) + (set! completions (cdr completions)) + (string-append dir completion))))) + (next->file-completion)))) + +(define (search-binary-in-path-completion text continue?) + (if (not continue?) + (let* ((paths (string-split (getenv "PATH") #\:)) + (binaries (apply append (filter identity (map scandir paths)))) + (completions (sort (filter (cut string-prefix? text <>) binaries) stringbinary-completion (lambda () + (if (null? completions) + #f + (let ((completion (car completions))) + (set! completions (cdr completions)) + completion)))) + (next->binary-completion)) + (next->binary-completion))) + +(define (completion text continue?) + (or (filename-completion text continue?) (search-binary-in-path-completion text continue?))) From 88a14cd2ae38c4c3a18c48c020502776e684f4f8 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Thu, 3 Nov 2016 00:39:18 +0100 Subject: [PATCH 053/312] fix globbing --- sh/anguish.scm | 25 +++++++++++++++---------- sh/pipe.scm | 6 +++++- 2 files changed, 20 insertions(+), 11 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 36fd373..0271a7d 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -83,6 +83,7 @@ copyleft. (quit (every identity status)))) (#t (let* ((HOME (string-append (getenv "HOME") "/.anguishistory")) (thunk (lambda () + ;;set-buffered-input-continuation?! (let loop ((line (readline (prompt)))) (if (not (eof-object? line)) (begin @@ -121,6 +122,7 @@ copyleft. ;; TODO: add braces (define (glob pattern) ;; pattern -> list of path + (define (glob? pattern) (string-match "\\?|\\*" pattern)) @@ -134,18 +136,21 @@ copyleft. (regexp-match? (regexp-exec regex path))) (define (glob- pattern paths) - (append-map (lambda (path) - (let ((empty? (string=? "" path))) - (map (lambda (extension) (if empty? extension (string-join (list path "/" extension) ""))) - (filter (cute glob-match (glob2regex pattern) <>) - (filter (negate (cut string-any #\. <> 0 1)) (scandir (if empty? (getcwd) path))))))) - paths)) + (map (lambda (path) + (if (string-prefix? "./" path) (string-drop path 2) path)) + (append-map (lambda (path) + (map (cute string-append (if (string=? "/" path) "" path) "/" <>) + (filter (conjoin (negate (cut string-prefix? "." <>)) + (cute glob-match (glob2regex pattern) <>)) + (or (scandir path) '())))) + paths))) (if (glob? pattern) - (let ((absolute? (char=? #\/ (string-ref pattern 0)))) - (let loop ((patterns (string-split pattern #\/)) - (paths (if absolute? '("/") `("")))) - (if (null? patterns) paths + (let* ((absolute? (string-prefix? "/" pattern))) + (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) + (paths (if absolute? '("/") '(".")))) + (if (null? patterns) + paths (loop (cdr patterns) (glob- (car patterns) paths))))) (list pattern))) diff --git a/sh/pipe.scm b/sh/pipe.scm index e97c695..453068b 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -8,7 +8,7 @@ :use-module (srfi srfi-9) :use-module (srfi srfi-26) - :export (pipeline job-control-init jobs report-jobs fg bg)) + :export (pipeline job-control-init jobs report-jobs fg bg disjoin conjoin)) (define (stdout . o) (map display o) @@ -174,6 +174,10 @@ (lambda (. arguments) (any (cut apply <> arguments) predicates))) +(define (conjoin . predicates) + (lambda (. arguments) + (every (cut apply <> arguments) predicates))) + (define (reap-jobs) (set! job-table (filter (disjoin job-running? job-stopped?) job-table))) From 2e3b805f6a4e5b805a0c8f9cd3b94d45e6429b81 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sun, 13 Nov 2016 23:33:30 +0100 Subject: [PATCH 054/312] introduce gash --- gash | 1 + 1 file changed, 1 insertion(+) create mode 100755 gash diff --git a/gash b/gash new file mode 100755 index 0000000..d0bede0 --- /dev/null +++ b/gash @@ -0,0 +1 @@ +guile -L . -e '(@ (sh anguish) main)' -s sh/anguish.scm $* From fc081e9c2be56f941bc2d0bfa9ff3a49851a7d62 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 16 Nov 2016 00:49:25 +0100 Subject: [PATCH 055/312] update peg for substitution in for and identifier reserved prefix --- sh/peg.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/sh/peg.scm b/sh/peg.scm index b1f9490..22b9974 100644 --- a/sh/peg.scm +++ b/sh/peg.scm @@ -54,7 +54,8 @@ case-item <-- pattern (ne-compound-list? case-sep ws* / error) case-sep < ';;' pattern <-- sp* word (sp* '|' sp* word)* sp* ')' sp* - for-clause <-- 'for' (sp+ identifier ws+ ('in' (sp+ word)* sp* sequential-sep)? do-group / error) + for-clause <-- 'for' (sp+ identifier ws+ ('in' expression sequential-sep)? do-group / error) + expression <-- sp+ substitution sp* / (sp+ word)* sp* do-group <-- 'do' (ne-compound-list 'done' / error) if-clause <-- 'if' (ne-compound-list 'then' ne-compound-list else-part? 'fi' / error) else-part <-- 'elif' (ne-compound-list 'then' ne-compound-list else-part? / error) / 'else' (ne-compound-list / error) @@ -65,7 +66,7 @@ brace-group <-- '{' (sp* (compound-list / error) sp* '}' / error) simple-command <-- (io-redirect sp+)* nonreserved (sp+ (io-redirect / nonreserved))* reserved < ('case' / 'esac' / 'if' / 'fi' / 'then' / 'else' / 'elif' / 'for' / 'done' / 'do' / 'until' / 'while') - nonreserved <- reserved word / !reserved word + nonreserved <- &(reserved word) word / !reserved word io-redirect <-- [0-9]* sp* (io-here / io-file) io-file <-- ('<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|') sp* ([0-9]+ / filename) io-here <- ('<<' / '<<-') io-suffix here-document From 559322ff5ab88412d330666ad8d67cae3506da33 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Thu, 1 Dec 2016 15:14:28 +0100 Subject: [PATCH 056/312] hacked 2nd prompt for incomplete inputs. --- sh/anguish.scm | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 0271a7d..75a763d 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -10,6 +10,7 @@ :use-module (ice-9 pretty-print) :use-module (ice-9 rdelim) :use-module (ice-9 readline) + :use-module (ice-9 buffered-input) :use-module (ice-9 regex) :use-module (sh pipe) @@ -83,15 +84,18 @@ copyleft. (quit (every identity status)))) (#t (let* ((HOME (string-append (getenv "HOME") "/.anguishistory")) (thunk (lambda () - ;;set-buffered-input-continuation?! + (set-readline-prompt! (prompt) "...") (let loop ((line (readline (prompt)))) (if (not (eof-object? line)) (begin (let ((ast (string-to-ast line))) - (if (not (string-null? line)) - (add-history line)) - (run ast)) - (loop (readline (prompt))))))))) + (when ast + (if (not (string-null? line)) + (add-history line)) + (run ast)) + (loop (string-append + (if ast "" (string-append line ";")) + (readline (if ast (prompt) "> "))))))))))) (clear-history) (read-history HOME) (with-readline-completion-function completion thunk) From 1a42685197a17028e2db64b174b8c60d51f217f4 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Thu, 1 Dec 2016 15:15:14 +0100 Subject: [PATCH 057/312] generalized gash for any call location --- gash | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gash b/gash index d0bede0..9a26feb 100755 --- a/gash +++ b/gash @@ -1 +1 @@ -guile -L . -e '(@ (sh anguish) main)' -s sh/anguish.scm $* +guile -L $(dirname $0) -e '(@ (sh anguish) main)' -s $(dirname $0)/sh/anguish.scm $* From b35876f4d95ef90abc0a019234622541d0a2d8ed Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sun, 5 Feb 2017 22:58:22 +0100 Subject: [PATCH 058/312] checkpoint: glob/regex fix, wip: 2nd prompt continuation, cleanups --- TODO | 13 +++++++++++++ sh/anguish.scm | 35 +++++++++++++++++------------------ sh/peg.scm | 4 ++-- 3 files changed, 32 insertions(+), 20 deletions(-) create mode 100644 TODO diff --git a/TODO b/TODO new file mode 100644 index 0000000..b0bc823 --- /dev/null +++ b/TODO @@ -0,0 +1,13 @@ +* setup test driven development: done +* execute tests using anguish: done +* parsing posix shell: nested "'""'": done +* globbing: done +* job control: done +* readline: prompt2: done? +* pipe: almost done: mix built-in with process +* compound: case, while, until +* expansion +* substitution +* alias +* redirection: +* posix compliance: diff --git a/sh/anguish.scm b/sh/anguish.scm index 75a763d..e02b330 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -1,13 +1,14 @@ (define-module (sh anguish) - :use-module (statprof) + + ;;:use-module (statprof) :use-module (srfi srfi-1) :use-module (srfi srfi-26) + :use-module (ice-9 ftw) :use-module (ice-9 getopt-long) :use-module (ice-9 local-eval) :use-module (ice-9 match) - :use-module (ice-9 pretty-print) :use-module (ice-9 rdelim) :use-module (ice-9 readline) :use-module (ice-9 buffered-input) @@ -84,18 +85,17 @@ copyleft. (quit (every identity status)))) (#t (let* ((HOME (string-append (getenv "HOME") "/.anguishistory")) (thunk (lambda () - (set-readline-prompt! (prompt) "...") (let loop ((line (readline (prompt)))) - (if (not (eof-object? line)) - (begin - (let ((ast (string-to-ast line))) - (when ast - (if (not (string-null? line)) - (add-history line)) - (run ast)) - (loop (string-append - (if ast "" (string-append line ";")) - (readline (if ast (prompt) "> "))))))))))) + (when (not (eof-object? line)) + (let ((ast (string-to-ast line))) + (when ast + (if (not (string-null? line)) + (add-history line)) + (run ast)) + (loop (let ((previous (if ast "" (string-append line "\n"))) + (next (readline (if ast (prompt) "> ")))) + (if (eof-object? next) next + (string-append previous next)))))))))) (clear-history) (read-history HOME) (with-readline-completion-function completion thunk) @@ -124,17 +124,16 @@ copyleft. ;; TODO: add braces - (define (glob pattern) ;; pattern -> list of path (define (glob? pattern) (string-match "\\?|\\*" pattern)) (define (glob2regex pattern) - (let* ((regex (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post)) - (regex (regexp-substitute/global #f "\\?" pattern 'pre "." 'post)) - (regex (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post))) - (make-regexp (string-append "^" regex "$")))) + (let* ((pattern (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post)) + (pattern (regexp-substitute/global #f "\\?" pattern 'pre "." 'post)) + (pattern (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post))) + (make-regexp (string-append "^" pattern "$")))) (define (glob-match regex path) ;; pattern path -> bool (regexp-match? (regexp-exec regex path))) diff --git a/sh/peg.scm b/sh/peg.scm index 22b9974..5c36924 100644 --- a/sh/peg.scm +++ b/sh/peg.scm @@ -1,7 +1,7 @@ (define-module (sh peg) :use-module (ice-9 peg) :use-module (ice-9 peg codegen) - :use-module (ice-9 pretty-print) + :export (parse)) (define (error? x) @@ -56,7 +56,7 @@ pattern <-- sp* word (sp* '|' sp* word)* sp* ')' sp* for-clause <-- 'for' (sp+ identifier ws+ ('in' expression sequential-sep)? do-group / error) expression <-- sp+ substitution sp* / (sp+ word)* sp* - do-group <-- 'do' (ne-compound-list 'done' / error) + do-group <-- 'do' ws* (ne-compound-list 'done' / error) if-clause <-- 'if' (ne-compound-list 'then' ne-compound-list else-part? 'fi' / error) else-part <-- 'elif' (ne-compound-list 'then' ne-compound-list else-part? / error) / 'else' (ne-compound-list / error) while-clause <-- 'while' (ne-compound-list do-group / error) From a0b61a24df674b1886c6c96e14010d8b619e5105 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sun, 12 Feb 2017 13:10:23 +0100 Subject: [PATCH 059/312] for-clause idiosynchrasies --- sh/anguish.scm | 30 ++++++++++++++++++------------ sh/peg.scm | 6 ++---- 2 files changed, 20 insertions(+), 16 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index e02b330..7488b50 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -1,7 +1,4 @@ (define-module (sh anguish) - - ;;:use-module (statprof) - :use-module (srfi srfi-1) :use-module (srfi srfi-26) @@ -101,7 +98,6 @@ copyleft. (with-readline-completion-function completion thunk) (write-history HOME)) (newline))))))) - ;;(statprof thunk #:hz 100 #:count-calls? #t) (thunk))) (define (remove-shell-comments s) @@ -158,6 +154,11 @@ copyleft. (list pattern))) +(define (background ast) + (match ast + (('pipeline fg rest ...) `(pipeline #f ,@rest)) + (_ ast))) + (define (builtin ast) (match ast (('append ('glob "cd") arg) `(apply chdir ,arg)) @@ -170,13 +171,9 @@ copyleft. (('glob "jobs") `(jobs)) (('for-each rest ...) ast) (('if rest ...) ast) + (#t #t) (_ #f))) -(define (background ast) - (match ast - (('pipeline fg rest ...) `(pipeline #f ,@rest)) - (_ ast))) - ;; transform ast -> list of expr ;; such that (map eval expr) @@ -189,9 +186,18 @@ copyleft. ((('term command) ...) (map transform command)) ((('term command) (('term commands) ...)) (map transform (cons command commands))) (('compound-list terms ...) (transform terms)) - (('if-clause "if" (expression "then" consequent "fi")) `(if (equal? 0 (status:exit-val (begin ,@(transform expression)))) (begin ,@(transform consequent)))) - (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) `(if (equal? 0 (status:exit-val ,@(transform expression))) (begin ,@(transform consequent)) (begin ,@(transform alternative)))) - (('for-clause "for" ((identifier "in" lst sep) do-group)) `(for-each (lambda (,(string->symbol identifier)) (begin ,@(expand identifier (transform do-group)))) (glob ,(transform lst)))) + (('if-clause "if" (expression "then" consequent "fi")) + `(if (equal? 0 (status:exit-val ,@(transform expression))) + (begin ,@(transform consequent)))) + (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) + `(if (equal? 0 (status:exit-val ,@(transform expression))) + (begin ,@(transform consequent)) + (begin ,@(transform alternative)))) + (('for-clause ("for" identifier sep do-group)) #t) + (('for-clause "for" ((identifier "in" lst sep) do-group)) + `(for-each (lambda (,(string->symbol identifier)) + (begin ,@(expand identifier (transform do-group)))) + (glob ,(transform lst)))) (('do-group "do" (command "done")) (transform command)) (('pipeline command) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,command)))) (('pipeline command piped-commands) `(pipeline #t ,(transform command) ,@(transform piped-commands))) diff --git a/sh/peg.scm b/sh/peg.scm index 5c36924..165c8bb 100644 --- a/sh/peg.scm +++ b/sh/peg.scm @@ -40,9 +40,7 @@ "script <-- ws* (term (separator term)* separator?)? eof eof < !. / error error <-- .* - term <-- pipeline (sp* (and / or) ws* pipeline)* - and <-- '&&' - or <-- '||' + term <-- pipeline (sp* ('&&' / '||') ws* pipeline)* pipeline <-- '!'? sp* command (sp* pipe ws* command)* pipe <-- '|' command <-- simple-command / (compound-command (sp+ io-redirect)*) / function-def @@ -54,7 +52,7 @@ case-item <-- pattern (ne-compound-list? case-sep ws* / error) case-sep < ';;' pattern <-- sp* word (sp* '|' sp* word)* sp* ')' sp* - for-clause <-- 'for' (sp+ identifier ws+ ('in' expression sequential-sep)? do-group / error) + for-clause <-- 'for' (sp+ identifier (ws+ 'in' expression sequential-sep / sp* sequential-sep) do-group / error) expression <-- sp+ substitution sp* / (sp+ word)* sp* do-group <-- 'do' ws* (ne-compound-list 'done' / error) if-clause <-- 'if' (ne-compound-list 'then' ne-compound-list else-part? 'fi' / error) From 2a1431da56b40ef17f2ef4599119239bfbf3a4ae Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 15 Feb 2017 23:10:24 +0100 Subject: [PATCH 060/312] refactor --- sh/anguish.scm | 116 ++++++++++++++++++++++++++----------------------- 1 file changed, 62 insertions(+), 54 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 7488b50..4782d9f 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -36,68 +36,76 @@ (define (file-to-ast filename) ((compose string-to-ast file-to-string) filename)) -(define (main args) - (setenv "PATH" "/bin:/usr/bin:/sbin:/usr/sbin:.") - (let ((thunk (lambda () - (job-control-init) - (let* ((option-spec '((debug (single-char #\d) (value #f)) - (help (single-char #\h) (value #f)) - (parse (single-char #\p) (value #f)) - (version (single-char #\v) (value #f)))) - (options (getopt-long args option-spec - #:stop-at-first-non-option #t )) - (help? (option-ref options 'help #f)) - (parse? (option-ref options 'parse (null? #f))) - (version? (option-ref options 'version #f)) - (files (option-ref options '() '())) - (run (lambda (ast) (and ast - (cond (parse? - (let ((ast- (transform ast))) - (format (current-output-port) "parsed : ~s\n\n" ast) - (format (current-output-port) "prepared : ~s\n\n" ast-) - #t)) - (#t - (sh-exec ast))))))) - (cond - (help? - (display "\ +(define (display-help) + (display "\ anguish [options] -h, --help Display this help -p, --parse Parse the shell script and print the parse tree -v, --version Display the version ")) - (version? - (display " + +(define (display-version) + (display " Anguish 0.1 + Copryright (C) 2016 R.E.W. van Beusekom, rutger.van.beusekom@gmail.com. This is anguish, ANother GUIle SHell, or the feeling you might have when your shell lacks a real programming language. Anguish is free software and is covered by the GNU Public License, see COPYING for the copyleft. + ")) - ((pair? files) - (let* ((asts (map file-to-ast files)) - (status (map run asts))) - (quit (every identity status)))) - (#t (let* ((HOME (string-append (getenv "HOME") "/.anguishistory")) - (thunk (lambda () - (let loop ((line (readline (prompt)))) - (when (not (eof-object? line)) - (let ((ast (string-to-ast line))) - (when ast - (if (not (string-null? line)) - (add-history line)) - (run ast)) - (loop (let ((previous (if ast "" (string-append line "\n"))) - (next (readline (if ast (prompt) "> ")))) - (if (eof-object? next) next - (string-append previous next)))))))))) - (clear-history) - (read-history HOME) - (with-readline-completion-function completion thunk) - (write-history HOME)) - (newline))))))) + +(define (main args) + (setenv "PATH" "/bin:/usr/bin:/sbin:/usr/sbin:.") + (let ((thunk + (lambda () + (job-control-init) + (let* ((option-spec '((debug (single-char #\d) (value #f)) + (help (single-char #\h) (value #f)) + (parse (single-char #\p) (value #f)) + (version (single-char #\v) (value #f)))) + (options (getopt-long args option-spec + #:stop-at-first-non-option #t )) + (help? (option-ref options 'help #f)) + (parse? (option-ref options 'parse (null? #f))) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '())) + (run + (lambda (ast) + (cond (parse? + (let ((ast- (transform ast))) + (format (current-output-port) "parsed : ~s\n\n" ast) + (format (current-output-port) "prepared : ~s\n\n" ast-) + #t)) + (#t + (sh-exec ast)))))) + (cond + (help? (display-help)) + (version? (display-version)) + ((pair? files) + (let* ((asts (map file-to-ast files)) + (status (map run asts))) + (quit (every identity status)))) + (#t (let* ((HOME (string-append (getenv "HOME") "/.anguishistory")) + (thunk (lambda () + (let loop ((line (readline (prompt)))) + (when (not (eof-object? line)) + (let ((ast (string-to-ast line))) + (when ast + (if (not (string-null? line)) + (add-history line)) + (run ast)) + (loop (let ((previous (if ast "" (string-append line "\n"))) + (next (readline (if ast (prompt) "> ")))) + (if (eof-object? next) next + (string-append previous next)))))))))) + (clear-history) + (read-history HOME) + (with-readline-completion-function completion thunk) + (write-history HOME)) + (newline))))))) (thunk))) (define (remove-shell-comments s) @@ -180,9 +188,9 @@ copyleft. (define (transform ast) (match ast (('script term "&") (list (background (transform term)))) - (('script term) (list (transform term))) + (('script term) `(,(transform term))) (('script terms ...) (transform terms)) - ((('term command)) (list (transform command))) + ((('term command)) `(,(transform command))) ((('term command) ...) (map transform command)) ((('term command) (('term commands) ...)) (map transform (cons command commands))) (('compound-list terms ...) (transform terms)) @@ -205,9 +213,9 @@ copyleft. (('simple-command ('word s1) ('word s2)) `(append (glob ,(transform s1)) (glob ,(transform s2)))) (('simple-command ('word s1) (('word s2) ...)) `(append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2))))) (('literal s) (transform s)) - (('singlequotes s) (string-concatenate (list "'" s "'"))) - (('doublequotes s) (string-concatenate (list "\"" s "\""))) - (('backticks s) (string-concatenate (list "`" s "`"))) + (('singlequotes s) (string-concatenate `("'" ,s "'"))) + (('doublequotes s) (string-concatenate `("\"" ,s "\""))) + (('backticks s) (string-concatenate `("`" ,s "`"))) (('delim ('singlequotes s ...)) (string-concatenate (map transform s))) (('delim ('doublequotes s ...)) (string-concatenate (map transform s))) (('delim ('backticks s ...)) (string-concatenate (map transform s))) From 34737293efce685e195cd6681f24c65365fcf3f8 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 15 Feb 2017 23:11:58 +0100 Subject: [PATCH 061/312] here document --- sh/anguish.scm | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 4782d9f..73ba42e 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -151,9 +151,8 @@ copyleft. (cute glob-match (glob2regex pattern) <>)) (or (scandir path) '())))) paths))) - (if (glob? pattern) - (let* ((absolute? (string-prefix? "/" pattern))) + (let ((absolute? (string-prefix? "/" pattern))) (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) (paths (if absolute? '("/") '(".")))) (if (null? patterns) @@ -161,7 +160,6 @@ copyleft. (loop (cdr patterns) (glob- (car patterns) paths))))) (list pattern))) - (define (background ast) (match ast (('pipeline fg rest ...) `(pipeline #f ,@rest)) @@ -207,11 +205,12 @@ copyleft. (begin ,@(expand identifier (transform do-group)))) (glob ,(transform lst)))) (('do-group "do" (command "done")) (transform command)) - (('pipeline command) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,command)))) - (('pipeline command piped-commands) `(pipeline #t ,(transform command) ,@(transform piped-commands))) - (('simple-command ('word s)) `(glob ,(transform s))) - (('simple-command ('word s1) ('word s2)) `(append (glob ,(transform s1)) (glob ,(transform s2)))) - (('simple-command ('word s1) (('word s2) ...)) `(append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2))))) + (('pipeline command) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,@command)))) + (('pipeline command piped-commands) `(pipeline #t ,@(transform command) ,@(transform piped-commands))) + (('simple-command ('word s)) `((glob ,(transform s)))) + (('simple-command ('word s1) ('io-redirect "<<" ('here-document s2))) `((append (glob "echo") (cons "-n" (glob ,s2))) (glob ,(transform s1)))) + (('simple-command ('word s1) ('word s2)) `((append (glob ,(transform s1)) (glob ,(transform s2))))) + (('simple-command ('word s1) (('word s2) ...)) `((append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2)))))) (('literal s) (transform s)) (('singlequotes s) (string-concatenate `("'" ,s "'"))) (('doublequotes s) (string-concatenate `("\"" ,s "\""))) @@ -219,8 +218,8 @@ copyleft. (('delim ('singlequotes s ...)) (string-concatenate (map transform s))) (('delim ('doublequotes s ...)) (string-concatenate (map transform s))) (('delim ('backticks s ...)) (string-concatenate (map transform s))) - ((('pipe _) command ...) (map transform command)) - (((('pipe _) command) ...) (map transform command)) + ((('pipe _) command) (transform command)) + (((('pipe _) command) ...) (map (compose car transform) command)) ((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...) (_ ast))) ;; done From 6b3351aa8a23a8f98559f12e18d018624f05d4fa Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sun, 19 Feb 2017 10:17:49 +0100 Subject: [PATCH 062/312] split off io --- sh/anguish.scm | 12 +----------- sh/io.scm | 16 ++++++++++++++++ sh/pipe.scm | 10 ++-------- 3 files changed, 19 insertions(+), 19 deletions(-) create mode 100644 sh/io.scm diff --git a/sh/anguish.scm b/sh/anguish.scm index 73ba42e..d120fdb 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -13,20 +13,10 @@ :use-module (sh pipe) :use-module (sh peg) + :use-module (sh io) :export (main)) -(define (stdout . o) - (map (lambda (o) (display o (current-output-port))) o) - (newline (current-output-port)) - (force-output (current-output-port)) - o) - -(define (stderr . o) - (map (lambda (o) (display o (current-error-port))) o) - (newline) - o) - (define (file-to-string filename) ((compose read-string open-input-file) filename)) diff --git a/sh/io.scm b/sh/io.scm new file mode 100644 index 0000000..67d3cb3 --- /dev/null +++ b/sh/io.scm @@ -0,0 +1,16 @@ +(define-module (sh io) + + :export (stdout stderr)) + +(define (output port . o) + (map (lambda (o) (display o port)) o) + (newline port) + (force-output port)) + +(define (stdout . o) + (output (current-output-port) o) + o) + +(define (stderr . o) + (output (current-error-port) o) + o) diff --git a/sh/pipe.scm b/sh/pipe.scm index 453068b..388ab5e 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -8,16 +8,10 @@ :use-module (srfi srfi-9) :use-module (srfi srfi-26) + :use-module (sh io) + :export (pipeline job-control-init jobs report-jobs fg bg disjoin conjoin)) -(define (stdout . o) - (map display o) - (newline)) - -(define (stderr . o) - (map (cute display <> (current-error-port)) o) - (newline)) - (define-record-type (make-process pid command status) process? From bb68e4728c8117ea14a47d595427f454c231e10f Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sun, 19 Feb 2017 10:22:41 +0100 Subject: [PATCH 063/312] split off util --- sh/anguish.scm | 1 + sh/pipe.scm | 11 ++--------- sh/util.scm | 13 +++++++++++++ 3 files changed, 16 insertions(+), 9 deletions(-) create mode 100644 sh/util.scm diff --git a/sh/anguish.scm b/sh/anguish.scm index d120fdb..96421ef 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -14,6 +14,7 @@ :use-module (sh pipe) :use-module (sh peg) :use-module (sh io) + :use-module (sh util) :export (main)) diff --git a/sh/pipe.scm b/sh/pipe.scm index 388ab5e..4df5e0d 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -9,8 +9,9 @@ :use-module (srfi srfi-26) :use-module (sh io) + :use-module (sh util) - :export (pipeline job-control-init jobs report-jobs fg bg disjoin conjoin)) + :export (pipeline job-control-init jobs report-jobs fg bg)) (define-record-type (make-process pid command status) @@ -164,14 +165,6 @@ (set! job-table (cons job job-table)) (if fg? (wait job)))) -(define (disjoin . predicates) - (lambda (. arguments) - (any (cut apply <> arguments) predicates))) - -(define (conjoin . predicates) - (lambda (. arguments) - (every (cut apply <> arguments) predicates))) - (define (reap-jobs) (set! job-table (filter (disjoin job-running? job-stopped?) job-table))) diff --git a/sh/util.scm b/sh/util.scm new file mode 100644 index 0000000..383b500 --- /dev/null +++ b/sh/util.scm @@ -0,0 +1,13 @@ +(define-module (sh util) + :use-module (srfi srfi-1) + :use-module (srfi srfi-26) + + :export (disjoin conjoin)) + +(define (disjoin . predicates) + (lambda (. arguments) + (any (cut apply <> arguments) predicates))) + +(define (conjoin . predicates) + (lambda (. arguments) + (every (cut apply <> arguments) predicates))) From 1bfb752b3c864c5883bb9ab72b3b2575c06fdf8d Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sun, 19 Feb 2017 10:56:18 +0100 Subject: [PATCH 064/312] split off job --- sh/anguish.scm | 1 + sh/job.scm | 140 +++++++++++++++++++++++++++++++++++++++++++++++++ sh/pipe.scm | 135 ++--------------------------------------------- 3 files changed, 144 insertions(+), 132 deletions(-) create mode 100644 sh/job.scm diff --git a/sh/anguish.scm b/sh/anguish.scm index 96421ef..dfd6282 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -11,6 +11,7 @@ :use-module (ice-9 buffered-input) :use-module (ice-9 regex) + :use-module (sh job) :use-module (sh pipe) :use-module (sh peg) :use-module (sh io) diff --git a/sh/job.scm b/sh/job.scm new file mode 100644 index 0000000..0d4f13e --- /dev/null +++ b/sh/job.scm @@ -0,0 +1,140 @@ +(define-module (sh job) + :use-module (srfi srfi-1) + :use-module (srfi srfi-8) + :use-module (srfi srfi-9) + :use-module (srfi srfi-26) + + :use-module (sh io) + :use-module (sh util) + + :export (job-control-init jobs report-jobs fg bg new-job job-add-process add-to-process-group wait)) + +(define-record-type + (make-process pid command status) + process? + (pid process-pid) + (command process-command) + (status process-status set-process-status!)) + +(define-record-type + (make-job id pgid processes) + job? + (id job-id) + (pgid job-pgid set-job-pgid!) + (processes job-processes set-job-processes!)) + +(define (new-job) + (let ((job (make-job (+ 1 (length job-table)) #f '()))) + (set! job-table (cons job job-table)) + job)) + +(define job-table '()) ;; list of + +(define (job-index index) + (let ((index (- (length job-table) index))) + (if (<= 0 index) + (list-ref job-table index) + #f))) + +(define (status->state status) + (cond ((not status) 'Running) + ((status:exit-val status) 'Done) + ((status:term-sig status) 'Terminated) + ((status:stop-sig status) 'Stopped))) + +(define (job-command job) + (string-join (map (compose string-join process-command) (reverse (job-processes job))) " | ")) + +(define (display-job job) + (stdout "[" (job-id job) "] " (status->state (job-status job)) "\t\t" + (job-command job))) + +(define (jobs) + (map (lambda (job) + (display-job job)) + (reverse job-table))) + +(define (job-status job) + (process-status (last (job-processes job)))) + +(define (job-update job pid status) + (unless (= 0 pid) + (let ((proc (find (compose (cut eqv? pid <>) process-pid) (job-processes job)))) + (when proc + (set-process-status! proc status))))) + +(define (job-running? job) + (find (compose not process-status) (job-processes job))) + +(define (job-stopped? job) + (find status:stop-sig (filter-map process-status (job-processes job)))) + +(define (job-completed? job) + (let ((state (map (compose status->state process-status) (job-processes job)))) + (every (cut member <> '(Done Terminated)) state))) + +(define (add-to-process-group job pid) + (let* ((pgid (job-pgid job)) + (pgid (or pgid pid))) + (setpgid pid pgid) + pgid)) + +(define (job-add-process fg? job pid command) + (let ((pgid (add-to-process-group job pid))) + (set-job-pgid! job pgid) + (if fg? (tcsetpgrp (current-error-port) pgid)) + (set-job-processes! job (cons (make-process pid command #f) (job-processes job))))) + +(define (job-control-init) + (let* ((interactive? (isatty? (current-error-port))) + (pgid (getpgrp)) + (pid (getpid))) + (when interactive? + (while (not (eqv? (tcgetpgrp (current-error-port)) pgid)) + (kill (- pgid) SIGTTIN)) ;; oops we are not in the foreground + (map (cut sigaction <> SIG_IGN) + (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU)) + (sigaction SIGCHLD SIG_DFL) + (setpgid pid pid) ;; create new process group for ourself + (tcsetpgrp (current-error-port) pid)))) + +(define (reap-jobs) + (set! job-table (filter (disjoin job-running? job-stopped?) job-table))) + +(define (report-jobs) + (when (not (null? job-table)) + (let* ((pid-status (waitpid WAIT_ANY (logior WUNTRACED WNOHANG))) + (pid (car pid-status)) + (status (cdr pid-status))) + (unless (= 0 pid) + (map (cut job-update <> pid status) job-table) + (map display-job (filter job-completed? job-table)) + (reap-jobs))))) + +(define (wait job) + (let loop () + (let* ((pid-status (waitpid (- (job-pgid job)) WUNTRACED)) + (pid (car pid-status)) + (status (cdr pid-status))) + (job-update job pid status) + (if (job-running? job) (loop)))) + (tcsetpgrp (current-error-port) (getpid)) + (unless (job-completed? job) + (newline) (display-job job)) + (reap-jobs) + (job-status job)) + +(define (fg index) + (let ((job (job-index index))) + (cond (job + (tcsetpgrp (current-error-port) (job-pgid job)) + (kill (- (job-pgid job)) SIGCONT) + (stdout (job-command job)) + (wait job)) + (#t + (stderr "fg: no such job " index))))) + +(define (bg index) + (let ((job (job-index index))) + (map (cut set-process-status! <> #f) (job-processes job)) + (kill (- (job-pgid job)) SIGCONT))) diff --git a/sh/pipe.scm b/sh/pipe.scm index 4df5e0d..1572a5a 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -1,101 +1,15 @@ (define-module (sh pipe) :use-module (ice-9 popen) - :use-module (ice-9 pretty-print) :use-module (srfi srfi-1) :use-module (srfi srfi-8) :use-module (srfi srfi-9) :use-module (srfi srfi-26) - :use-module (sh io) - :use-module (sh util) + :use-module (sh job) - :export (pipeline job-control-init jobs report-jobs fg bg)) - -(define-record-type - (make-process pid command status) - process? - (pid process-pid) - (command process-command) - (status process-status set-process-status!)) - -(define-record-type - (make-job id pgid processes) - job? - (id job-id) - (pgid job-pgid set-job-pgid!) - (processes job-processes set-job-processes!)) - -(define job-table '()) ;; list of - -(define (job-index index) - (let ((index (- (length job-table) index))) - (if (<= 0 index) - (list-ref job-table index) - #f))) - -(define (status->state status) - (cond ((not status) 'Running) - ((status:exit-val status) 'Done) - ((status:term-sig status) 'Terminated) - ((status:stop-sig status) 'Stopped))) - -(define (job-command job) - (string-join (map (compose string-join process-command) (reverse (job-processes job))) " | ")) - -(define (display-job job) - (stdout "[" (job-id job) "] " (status->state (job-status job)) "\t\t" - (job-command job))) - -(define (jobs) - (map (lambda (job) - (display-job job)) - (reverse job-table))) - -(define (job-status job) - (process-status (last (job-processes job)))) - -(define (job-update job pid status) - (unless (= 0 pid) - (let ((proc (find (compose (cut eqv? pid <>) process-pid) (job-processes job)))) - (when proc - (set-process-status! proc status))))) - -(define (job-running? job) - (find (compose not process-status) (job-processes job))) - -(define (job-stopped? job) - (find status:stop-sig (filter-map process-status (job-processes job)))) - -(define (job-completed? job) - (let ((state (map (compose status->state process-status) (job-processes job)))) - (every (cut member <> '(Done Terminated)) state))) - -(define (add-to-process-group job pid) - (let* ((pgid (job-pgid job)) - (pgid (or pgid pid))) - (setpgid pid pgid) - pgid)) - -(define (job-add-process fg? job pid command) - (let ((pgid (add-to-process-group job pid))) - (set-job-pgid! job pgid) - (if fg? (tcsetpgrp (current-error-port) pgid)) - (set-job-processes! job (cons (make-process pid command #f) (job-processes job))))) - -(define (job-control-init) - (let* ((interactive? (isatty? (current-error-port))) - (pgid (getpgrp)) - (pid (getpid))) - (when interactive? - (while (not (eqv? (tcgetpgrp (current-error-port)) pgid)) - (kill (- pgid) SIGTTIN)) ;; oops we are not in the foreground - (map (cut sigaction <> SIG_IGN) - (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU)) - (sigaction SIGCHLD SIG_DFL) - (setpgid pid pid) ;; create new process group for ourself - (tcsetpgrp (current-error-port) pid)))) + :export (pipeline)) (define (pipe*) (let ((p (pipe))) @@ -152,8 +66,7 @@ (define (pipeline fg? . commands) - (let* ((index (+ 1 (length job-table))) - (job (make-job index #f '()))) + (let ((job (new-job))) (if (> (length commands) 1) (let loop ((src (spawn-source fg? job (car commands))) (commands (cdr commands))) @@ -162,49 +75,7 @@ (loop (spawn-filter fg? job src (car commands)) (cdr commands)))) (spawn-sink fg? job #f (car commands))) - (set! job-table (cons job job-table)) (if fg? (wait job)))) -(define (reap-jobs) - (set! job-table (filter (disjoin job-running? job-stopped?) job-table))) - -(define (report-jobs) - (when (not (null? job-table)) - (let* ((pid-status (waitpid WAIT_ANY (logior WUNTRACED WNOHANG))) - (pid (car pid-status)) - (status (cdr pid-status))) - (unless (= 0 pid) - (map (cut job-update <> pid status) job-table) - (map display-job (filter job-completed? job-table)) - (reap-jobs))))) - -(define (wait job) - (let loop () - (let* ((pid-status (waitpid (- (job-pgid job)) WUNTRACED)) - (pid (car pid-status)) - (status (cdr pid-status))) - (job-update job pid status) - (if (job-running? job) (loop)))) - (tcsetpgrp (current-error-port) (getpid)) - (unless (job-completed? job) - (newline) (display-job job)) - (reap-jobs) - (job-status job)) - -(define (fg index) - (let ((job (job-index index))) - (cond (job - (tcsetpgrp (current-error-port) (job-pgid job)) - (kill (- (job-pgid job)) SIGCONT) - (stdout (job-command job)) - (wait job)) - (#t - (stderr "fg: no such job " index))))) - -(define (bg index) - (let ((job (job-index index))) - (map (cut set-process-status! <> #f) (job-processes job)) - (kill (- (job-pgid job)) SIGCONT))) - ;;(pipeline (list "ls" "/") ;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) From 0a75234e5202689410105363ddabd07e49f121ca Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sun, 19 Feb 2017 13:49:30 +0100 Subject: [PATCH 065/312] complete rename from anguish to gash --- README | 10 ---------- TODO | 2 +- anguish | 12 ------------ bin/gash | 1 + gash | 1 - sh/anguish.scm => gash/gash.scm | 25 ++++++++++++------------- {sh => gash}/io.scm | 2 +- {sh => gash}/job.scm | 6 +++--- {sh => gash}/peg.scm | 2 +- {sh => gash}/pipe.scm | 4 ++-- {sh => gash}/util.scm | 2 +- test-anguish.sh | 2 -- test-bash.sh | 2 -- 13 files changed, 22 insertions(+), 49 deletions(-) delete mode 100755 anguish create mode 100755 bin/gash delete mode 100755 gash rename sh/anguish.scm => gash/gash.scm (96%) rename {sh => gash}/io.scm (91%) rename {sh => gash}/job.scm (98%) rename {sh => gash}/peg.scm (99%) rename {sh => gash}/pipe.scm (97%) rename {sh => gash}/util.scm (91%) delete mode 100755 test-anguish.sh delete mode 100755 test-bash.sh diff --git a/README b/README index af48962..f2ce0f1 100644 --- a/README +++ b/README @@ -1,11 +1,3 @@ -ANGUISH: that which you might experience when your shell -falls short of expressing your programming solution - -or - -AN[other] GUIle SHell -Anguish is Not a GUIle SHell - This project aims to produce at least a POSIX compliant sh replacement or even implement GNU bash. On top of that it also intends to make scheme available for interactive and scripting application. The @@ -24,7 +16,5 @@ functional programming, however now I mostly experience that the language itselfs folds on functional expression, pun intended. - - * history flattened vs full, i.e. navigate interactively without redundancy vs export as script diff --git a/TODO b/TODO index b0bc823..178cd71 100644 --- a/TODO +++ b/TODO @@ -1,5 +1,5 @@ * setup test driven development: done -* execute tests using anguish: done +* execute tests using gash: done * parsing posix shell: nested "'""'": done * globbing: done * job control: done diff --git a/anguish b/anguish deleted file mode 100755 index a59d3c4..0000000 --- a/anguish +++ /dev/null @@ -1,12 +0,0 @@ -#!/usr/bin/guile \ ---debug -e main -s -!# -;; workaround: -;; -e (@ (sh anguish) main) -s -;; leads to: -;; ERROR: In procedure read: -;; ERROR: In procedure scm_i_lreadparen: #:1:3: end of file - -(define (main args) - (set! %load-path (cons (dirname (car args)) %load-path)) - ((@ (sh anguish) main) args)) diff --git a/bin/gash b/bin/gash new file mode 100755 index 0000000..45aae8b --- /dev/null +++ b/bin/gash @@ -0,0 +1 @@ +guile -L $(dirname $0)/.. -e '(@ (gash gash) main)' -s $(dirname $0)/../gash/gash.scm $* diff --git a/gash b/gash deleted file mode 100755 index 9a26feb..0000000 --- a/gash +++ /dev/null @@ -1 +0,0 @@ -guile -L $(dirname $0) -e '(@ (sh anguish) main)' -s $(dirname $0)/sh/anguish.scm $* diff --git a/sh/anguish.scm b/gash/gash.scm similarity index 96% rename from sh/anguish.scm rename to gash/gash.scm index dfd6282..cde0ccb 100644 --- a/sh/anguish.scm +++ b/gash/gash.scm @@ -1,4 +1,5 @@ -(define-module (sh anguish) +(define-module (gash gash) + :use-module (srfi srfi-1) :use-module (srfi srfi-26) @@ -11,11 +12,11 @@ :use-module (ice-9 buffered-input) :use-module (ice-9 regex) - :use-module (sh job) - :use-module (sh pipe) - :use-module (sh peg) - :use-module (sh io) - :use-module (sh util) + :use-module (gash job) + :use-module (gash pipe) + :use-module (gash peg) + :use-module (gash io) + :use-module (gash util) :export (main)) @@ -30,7 +31,7 @@ (define (display-help) (display "\ -anguish [options] +gash [options] -h, --help Display this help -p, --parse Parse the shell script and print the parse tree -v, --version Display the version @@ -38,14 +39,12 @@ anguish [options] (define (display-version) (display " -Anguish 0.1 +GASH 0.1 Copryright (C) 2016 R.E.W. van Beusekom, rutger.van.beusekom@gmail.com. -This is anguish, ANother GUIle SHell, or the feeling you might have -when your shell lacks a real programming language. Anguish is free -software and is covered by the GNU Public License, see COPYING for the -copyleft. +This is gash, Guile As SHell. Gash is free software and is covered by +the GNU Public License, see COPYING for the copyleft. ")) @@ -80,7 +79,7 @@ copyleft. (let* ((asts (map file-to-ast files)) (status (map run asts))) (quit (every identity status)))) - (#t (let* ((HOME (string-append (getenv "HOME") "/.anguishistory")) + (#t (let* ((HOME (string-append (getenv "HOME") "/.gash_history")) (thunk (lambda () (let loop ((line (readline (prompt)))) (when (not (eof-object? line)) diff --git a/sh/io.scm b/gash/io.scm similarity index 91% rename from sh/io.scm rename to gash/io.scm index 67d3cb3..28a3b7c 100644 --- a/sh/io.scm +++ b/gash/io.scm @@ -1,4 +1,4 @@ -(define-module (sh io) +(define-module (gash io) :export (stdout stderr)) diff --git a/sh/job.scm b/gash/job.scm similarity index 98% rename from sh/job.scm rename to gash/job.scm index 0d4f13e..306d3f3 100644 --- a/sh/job.scm +++ b/gash/job.scm @@ -1,11 +1,11 @@ -(define-module (sh job) +(define-module (gash job) :use-module (srfi srfi-1) :use-module (srfi srfi-8) :use-module (srfi srfi-9) :use-module (srfi srfi-26) - :use-module (sh io) - :use-module (sh util) + :use-module (gash io) + :use-module (gash util) :export (job-control-init jobs report-jobs fg bg new-job job-add-process add-to-process-group wait)) diff --git a/sh/peg.scm b/gash/peg.scm similarity index 99% rename from sh/peg.scm rename to gash/peg.scm index 165c8bb..591fb1f 100644 --- a/sh/peg.scm +++ b/gash/peg.scm @@ -1,4 +1,4 @@ -(define-module (sh peg) +(define-module (gash peg) :use-module (ice-9 peg) :use-module (ice-9 peg codegen) diff --git a/sh/pipe.scm b/gash/pipe.scm similarity index 97% rename from sh/pipe.scm rename to gash/pipe.scm index 1572a5a..88ac290 100644 --- a/sh/pipe.scm +++ b/gash/pipe.scm @@ -1,4 +1,4 @@ -(define-module (sh pipe) +(define-module (gash pipe) :use-module (ice-9 popen) @@ -7,7 +7,7 @@ :use-module (srfi srfi-9) :use-module (srfi srfi-26) - :use-module (sh job) + :use-module (gash job) :export (pipeline)) diff --git a/sh/util.scm b/gash/util.scm similarity index 91% rename from sh/util.scm rename to gash/util.scm index 383b500..a0ecc52 100644 --- a/sh/util.scm +++ b/gash/util.scm @@ -1,4 +1,4 @@ -(define-module (sh util) +(define-module (gash util) :use-module (srfi srfi-1) :use-module (srfi srfi-26) diff --git a/test-anguish.sh b/test-anguish.sh deleted file mode 100755 index 465b064..0000000 --- a/test-anguish.sh +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/bash -for f in test/*; do echo $f; ./anguish $f; done diff --git a/test-bash.sh b/test-bash.sh deleted file mode 100755 index e16eb8d..0000000 --- a/test-bash.sh +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/bash -for f in test/*; do echo $f; bash $f; done From 57b93d2902d600695173228e02d7db815811ffdd Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sun, 19 Feb 2017 15:02:54 +0100 Subject: [PATCH 066/312] substitution WIP --- gash/gash.scm | 1 + gash/peg.scm | 3 +-- test/substitution | 1 - todo/substitution | 1 + 4 files changed, 3 insertions(+), 3 deletions(-) delete mode 100644 test/substitution create mode 100644 todo/substitution diff --git a/gash/gash.scm b/gash/gash.scm index cde0ccb..b2101c8 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -179,6 +179,7 @@ the GNU Public License, see COPYING for the copyleft. (('script term "&") (list (background (transform term)))) (('script term) `(,(transform term))) (('script terms ...) (transform terms)) + (('substitution "$(" (script) ")") (stderr "FOO: " (transform script)) (transform script)) ((('term command)) `(,(transform command))) ((('term command) ...) (map transform command)) ((('term command) (('term commands) ...)) (map transform (cons command commands))) diff --git a/gash/peg.scm b/gash/peg.scm index 591fb1f..5e77307 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -37,8 +37,7 @@ (define-peg-pattern here-document all (and (+ (and (not-followed-by here-delim) peg-any)) here-delim)) (define-peg-string-patterns - "script <-- ws* (term (separator term)* separator?)? eof - eof < !. / error + "script <-- ws* (term (separator term)* separator?)? error <-- .* term <-- pipeline (sp* ('&&' / '||') ws* pipeline)* pipeline <-- '!'? sp* command (sp* pipe ws* command)* diff --git a/test/substitution b/test/substitution deleted file mode 100644 index 5c1f26d..0000000 --- a/test/substitution +++ /dev/null @@ -1 +0,0 @@ -echo "$(ls)" diff --git a/todo/substitution b/todo/substitution new file mode 100644 index 0000000..9c3f223 --- /dev/null +++ b/todo/substitution @@ -0,0 +1 @@ +echo $(find test -type f) From e348606d369f6889bcf7ccfdadd874397c2ae20c Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Mon, 20 Feb 2017 15:44:39 +0100 Subject: [PATCH 067/312] testing --- test.sh | 1 + test/find | 1 + test/iohere | 4 ++++ 3 files changed, 6 insertions(+) create mode 100755 test.sh create mode 100644 test/find create mode 100644 test/iohere diff --git a/test.sh b/test.sh new file mode 100755 index 0000000..60db800 --- /dev/null +++ b/test.sh @@ -0,0 +1 @@ +for f in test/*; do echo $f ":"; bin/gash $f; echo; done diff --git a/test/find b/test/find new file mode 100644 index 0000000..190b922 --- /dev/null +++ b/test/find @@ -0,0 +1 @@ +find test -type f diff --git a/test/iohere b/test/iohere new file mode 100644 index 0000000..12cda66 --- /dev/null +++ b/test/iohere @@ -0,0 +1,4 @@ +cat < Date: Sat, 25 Feb 2017 11:01:58 +0100 Subject: [PATCH 068/312] substitution --- gash/gash.scm | 2 +- gash/pipe.scm | 32 ++++++++++++++++++++++++++++---- {todo => test}/substitution | 0 3 files changed, 29 insertions(+), 5 deletions(-) rename {todo => test}/substitution (100%) diff --git a/gash/gash.scm b/gash/gash.scm index b2101c8..4dec2bf 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -179,7 +179,7 @@ the GNU Public License, see COPYING for the copyleft. (('script term "&") (list (background (transform term)))) (('script term) `(,(transform term))) (('script terms ...) (transform terms)) - (('substitution "$(" (script) ")") (stderr "FOO: " (transform script)) (transform script)) + (('substitution "$(" (script ")")) (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment))) ((('term command)) `(,(transform command))) ((('term command) ...) (map transform command)) ((('term command) (('term commands) ...)) (map transform (cons command commands))) diff --git a/gash/pipe.scm b/gash/pipe.scm index 88ac290..cdd6169 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -1,6 +1,7 @@ (define-module (gash pipe) :use-module (ice-9 popen) + :use-module (ice-9 rdelim) :use-module (srfi srfi-1) :use-module (srfi srfi-8) @@ -9,7 +10,7 @@ :use-module (gash job) - :export (pipeline)) + :export (pipeline substitute)) (define (pipe*) (let ((p (pipe))) @@ -45,7 +46,7 @@ (let ((pid (primitive-fork))) (cond ((= 0 pid) (setup-process fg? job) - (move->fdes src 0) + (if src (move->fdes src 0)) (close r) (move->fdes w 1) (exec* command)) @@ -77,5 +78,28 @@ (spawn-sink fg? job #f (car commands))) (if fg? (wait job)))) -;;(pipeline (list "ls" "/") -;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) +;;(pipeline #f (list "ls" "/")) +;;(pipeline #f (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) + +(define (read-n-format r) + (string-trim (string-map (lambda (c) + (if (eq? #\newline c) #\space c)) + (read-string r)) + #\space)) + +(define (substitute . commands) + (let* ((fg? #f) + (job (new-job)) + (output (read-n-format + (if (> (length commands) 1) + (let loop ((src (spawn-source fg? job (car commands))) + (commands (cdr commands))) + (if (null? (cdr commands)) + (spawn-filter fg? job src (car commands)) + (loop (spawn-filter fg? job src (car commands)) + (cdr commands)))) + (spawn-filter fg? job #f (car commands)))))) + (wait job) + output)) + +;;(display (substitute '("ls") '("cat"))) (newline) diff --git a/todo/substitution b/test/substitution similarity index 100% rename from todo/substitution rename to test/substitution From 6e556508f5683431b31fbbce9f14e7e2b8e6cf1a Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sat, 8 Apr 2017 21:39:43 +0200 Subject: [PATCH 069/312] checkpoint --- TODO | 10 +++++----- gash/gash.scm | 38 ++++++++++++++++++++++++++++---------- gash/io.scm | 2 +- gash/peg.scm | 6 +++--- test/assignment | 1 + test/for | 2 +- test/test | 3 +++ test/var | 1 + 8 files changed, 43 insertions(+), 20 deletions(-) create mode 100644 test/assignment create mode 100644 test/test create mode 100644 test/var diff --git a/TODO b/TODO index 178cd71..674e9ea 100644 --- a/TODO +++ b/TODO @@ -3,11 +3,11 @@ * parsing posix shell: nested "'""'": done * globbing: done * job control: done -* readline: prompt2: done? -* pipe: almost done: mix built-in with process +* substitution: done +* readline: prompt2: in progress +* pipe: in progress: mix built-in with process * compound: case, while, until -* expansion -* substitution -* alias +* expansion: done +* alias: * redirection: * posix compliance: diff --git a/gash/gash.scm b/gash/gash.scm index 4dec2bf..086fb9b 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -20,11 +20,27 @@ :export (main)) +(define (remove-shell-comments s) + (string-join (map + (lambda (s) + (let* ((n (string-index s #\#))) + (if n (string-pad-right s (string-length s) #\space 0 n) + s))) + (string-split s #\newline)) "\n")) + +(define (remove-escaped-newlines s) + (reduce (lambda (next prev) + (let* ((escaped? (string-suffix? "\\" next)) + (next (if escaped? (string-drop-right next 1) next)) + (sep (if escaped? "" "\n"))) + (string-append prev sep next))) + "" (string-split s #\newline))) + (define (file-to-string filename) - ((compose read-string open-input-file) filename)) + ((compose read-string open-input-file) filename)) (define (string-to-ast string) - ((compose parse remove-shell-comments) string)) + ((compose parse remove-escaped-newlines remove-shell-comments) string)) (define (file-to-ast filename) ((compose string-to-ast file-to-string) filename)) @@ -48,8 +64,16 @@ the GNU Public License, see COPYING for the copyleft. ")) +(define global-variables '()) + (define (main args) (setenv "PATH" "/bin:/usr/bin:/sbin:/usr/sbin:.") + (map (lambda (key-value) + (let* ((key-value (string-split key-value #\=)) + (key (car key-value)) + (value (cadr key-value))) + (set! global-variables (assoc-set! global-variables key value)))) + (environ)) (let ((thunk (lambda () (job-control-init) @@ -99,14 +123,6 @@ the GNU Public License, see COPYING for the copyleft. (newline))))))) (thunk))) -(define (remove-shell-comments s) - (string-join (map - (lambda (s) - (let* ((n (string-index s #\#))) - (if n (string-pad-right s (string-length s) #\space 0 n) - s))) - (string-split s #\newline)) "\n")) - (define (expand identifier o) ;;identifier-string -> symbol (define (expand- o) (let ((dollar-identifier (string-append "$" identifier))) @@ -199,10 +215,12 @@ the GNU Public License, see COPYING for the copyleft. (('do-group "do" (command "done")) (transform command)) (('pipeline command) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,@command)))) (('pipeline command piped-commands) `(pipeline #t ,@(transform command) ,@(transform piped-commands))) + (('simple-command ('word (assignment name value))) (set! global-variables (assoc-set! global-variables (transform name) (transform value))) #t) (('simple-command ('word s)) `((glob ,(transform s)))) (('simple-command ('word s1) ('io-redirect "<<" ('here-document s2))) `((append (glob "echo") (cons "-n" (glob ,s2))) (glob ,(transform s1)))) (('simple-command ('word s1) ('word s2)) `((append (glob ,(transform s1)) (glob ,(transform s2))))) (('simple-command ('word s1) (('word s2) ...)) `((append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2)))))) + (('variable s) (assoc-ref global-variables (string-drop s 1))) (('literal s) (transform s)) (('singlequotes s) (string-concatenate `("'" ,s "'"))) (('doublequotes s) (string-concatenate `("\"" ,s "\""))) diff --git a/gash/io.scm b/gash/io.scm index 28a3b7c..6f64b34 100644 --- a/gash/io.scm +++ b/gash/io.scm @@ -2,7 +2,7 @@ :export (stdout stderr)) -(define (output port . o) +(define (output port o) (map (lambda (o) (display o port)) o) (newline port) (force-output port)) diff --git a/gash/peg.scm b/gash/peg.scm index 5e77307..e19743d 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -54,8 +54,8 @@ for-clause <-- 'for' (sp+ identifier (ws+ 'in' expression sequential-sep / sp* sequential-sep) do-group / error) expression <-- sp+ substitution sp* / (sp+ word)* sp* do-group <-- 'do' ws* (ne-compound-list 'done' / error) - if-clause <-- 'if' (ne-compound-list 'then' ne-compound-list else-part? 'fi' / error) - else-part <-- 'elif' (ne-compound-list 'then' ne-compound-list else-part? / error) / 'else' (ne-compound-list / error) + if-clause <-- 'if' (ne-compound-list 'then' ws* ne-compound-list else-part? 'fi' / error) + else-part <-- 'elif' (ne-compound-list 'then' ws* ne-compound-list else-part? / error) / 'else' (ne-compound-list / error) while-clause <-- 'while' (ne-compound-list do-group / error) until-clause <-- 'until' (ne-compound-list do-group / error) function-def <-- name sp* '(' sp* ')' ws* (function-body / error) @@ -78,7 +78,7 @@ ltest < '[ ' rtest < ' ]' substitution <-- ('$(' (script ')' / error)) / ('`' (script '`' / error)) - assignment <-- name assign word? + assignment <-- name assign (substitution / word)? assign < '=' literal <-- (variable / delim / (![0-9] (![()] !io-op !sp !nl !break !pipe !assign .)+) / ([0-9]+ &separator)) literal* variable <-- '$' ('$' / '*' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) diff --git a/test/assignment b/test/assignment new file mode 100644 index 0000000..835e1dc --- /dev/null +++ b/test/assignment @@ -0,0 +1 @@ +SHELL=/bin/bash diff --git a/test/for b/test/for index 72e0d88..8760e30 100644 --- a/test/for +++ b/test/for @@ -1 +1 @@ -for f in *; do echo $f | grep c; done +for f in *; do echo "$f:" | grep c; done diff --git a/test/test b/test/test new file mode 100644 index 0000000..b0d45ce --- /dev/null +++ b/test/test @@ -0,0 +1,3 @@ +foo=bar +bar=foo +if [ "${foo}" != "foo" -a "${bar}" != "bar" ]; then echo foobar; fi diff --git a/test/var b/test/var new file mode 100644 index 0000000..6cfa9fa --- /dev/null +++ b/test/var @@ -0,0 +1 @@ +echo $SHELL From 2446a63281fa172af4dfe650e58b454e0abf1ce2 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sun, 9 Apr 2017 16:04:54 +0200 Subject: [PATCH 070/312] catch all errors --- gash/pipe.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/gash/pipe.scm b/gash/pipe.scm index cdd6169..2037298 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -20,7 +20,9 @@ ;; [source] w -> r [filter] w -> r [sink] (define (exec* command) ;; list of strings - (apply execlp (cons (car command) command))) + (catch #t (lambda () (apply execlp (cons (car command) command))) + (lambda (key . args) (display (string-append (caaddr args) "\n")) + (exit #f)))) (define (setup-process fg? job) (when (isatty? (current-error-port)) From f171f79ec9c3e7f545858e032844f90c1ad0c50b Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Mon, 15 May 2017 23:14:54 +0200 Subject: [PATCH 071/312] substitution --- gash/gash.scm | 4 +++- gash/peg.scm | 15 +++++++-------- gash/pipe.scm | 20 +++++++++++--------- test/substitution | 1 + 4 files changed, 22 insertions(+), 18 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index 086fb9b..e4e7cdc 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -48,6 +48,7 @@ (define (display-help) (display "\ gash [options] + -d, --debug Enable PEG tracing -h, --help Display this help -p, --parse Parse the shell script and print the parse tree -v, --version Display the version @@ -195,7 +196,8 @@ the GNU Public License, see COPYING for the copyleft. (('script term "&") (list (background (transform term)))) (('script term) `(,(transform term))) (('script terms ...) (transform terms)) - (('substitution "$(" (script ")")) (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment))) + (('substitution "$(" script ")") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment))) + (('substitution "`" script "`") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment))) ((('term command)) `(,(transform command))) ((('term command) ...) (map transform command)) ((('term command) (('term commands) ...)) (map transform (cons command commands))) diff --git a/gash/peg.scm b/gash/peg.scm index e19743d..e1b7ced 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -2,7 +2,7 @@ :use-module (ice-9 peg) :use-module (ice-9 peg codegen) - :export (parse)) + :export (parse peg-trace?)) (define (error? x) (let loop ((x x)) @@ -62,7 +62,7 @@ function-body <-- compound-command io-redirect* brace-group <-- '{' (sp* (compound-list / error) sp* '}' / error) simple-command <-- (io-redirect sp+)* nonreserved (sp+ (io-redirect / nonreserved))* - reserved < ('case' / 'esac' / 'if' / 'fi' / 'then' / 'else' / 'elif' / 'for' / 'done' / 'do' / 'until' / 'while') + reserved < 'case' / 'esac' / 'if' / 'fi' / 'then' / 'else' / 'elif' / 'for' / 'done' / 'do' / 'until' / 'while' nonreserved <- &(reserved word) word / !reserved word io-redirect <-- [0-9]* sp* (io-here / io-file) io-file <-- ('<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|') sp* ([0-9]+ / filename) @@ -77,18 +77,17 @@ test <-- ltest (!rtest .)* rtest ltest < '[ ' rtest < ' ]' - substitution <-- ('$(' (script ')' / error)) / ('`' (script '`' / error)) + substitution <-- ('$(' script ')') / ('`' script '`') assignment <-- name assign (substitution / word)? assign < '=' - literal <-- (variable / delim / (![0-9] (![()] !io-op !sp !nl !break !pipe !assign .)+) / ([0-9]+ &separator)) literal* + literal <-- (variable / delim / (![0-9] (![()] !io-op !sp !nl !break !pipe !assign !bt !sq !dq .)+) / ([0-9]+ &separator)) literal* variable <-- '$' ('$' / '*' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) - delim <-- singlequotes / doublequotes / backticks + delim <-- singlequotes / doublequotes / substitution sq < ['] dq < [\"] bt < [`] - singlequotes <-- sq ((doublequotes / backticks / (!sq .))* sq) - doublequotes <-- dq ((singlequotes / backticks / (!dq .))* dq) - backticks <-- bt ((singlequotes / doublequotes / (!bt .))* bt) + singlequotes <-- sq (doublequotes / substitution / (!sq .))* sq + doublequotes <-- dq (singlequotes / substitution / (!dq .))* dq separator <- (sp* break ws*) / ws+ break <- amp / semi !semi sequential-sep <-- (semi !semi ws*) / ws+ diff --git a/gash/pipe.scm b/gash/pipe.scm index 2037298..a73deb3 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -83,16 +83,10 @@ ;;(pipeline #f (list "ls" "/")) ;;(pipeline #f (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) -(define (read-n-format r) - (string-trim (string-map (lambda (c) - (if (eq? #\newline c) #\space c)) - (read-string r)) - #\space)) - -(define (substitute . commands) +(define (pipeline->string . commands) (let* ((fg? #f) (job (new-job)) - (output (read-n-format + (output (read-string (if (> (length commands) 1) (let loop ((src (spawn-source fg? job (car commands))) (commands (cdr commands))) @@ -104,4 +98,12 @@ (wait job) output)) -;;(display (substitute '("ls") '("cat"))) (newline) +(define (substitute . commands) + (string-trim-right + (string-map (lambda (c) + (if (eq? #\newline c) #\space c)) + (apply pipeline->string commands)) + #\space)) + +;; (display (pipeline->string '("ls") '("cat"))) (newline) +;; (display (substitute '("ls") '("cat"))) (newline) diff --git a/test/substitution b/test/substitution index 9c3f223..2b87ce6 100644 --- a/test/substitution +++ b/test/substitution @@ -1 +1,2 @@ echo $(find test -type f) +echo `find test -type f` From 9856ad76198e290f1b41626aaeb034e8e2f16654 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Thu, 7 Dec 2017 22:46:21 +0100 Subject: [PATCH 072/312] fix builtins --- gash/gash.scm | 23 ++++++++++------------- gash/job.scm | 6 +++--- gash/pipe.scm | 2 +- 3 files changed, 14 insertions(+), 17 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index e4e7cdc..c384fed 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -68,7 +68,6 @@ the GNU Public License, see COPYING for the copyleft. (define global-variables '()) (define (main args) - (setenv "PATH" "/bin:/usr/bin:/sbin:/usr/sbin:.") (map (lambda (key-value) (let* ((key-value (string-split key-value #\=)) (key (car key-value)) @@ -174,15 +173,16 @@ the GNU Public License, see COPYING for the copyleft. (_ ast))) (define (builtin ast) + ;;(stdout "builtin: " ast "\n") (match ast - (('append ('glob "cd") arg) `(apply chdir ,arg)) - (('append ('glob "fg") ('glob arg)) `(fg ,(string->number arg))) - (('append ('glob "bg") ('glob arg)) `(bg ,(string->number arg))) - (('append ('glob "echo") args ...) `(stdout (string-join ,@args " "))) - (('glob "echo") `(stdout)) - (('glob "fg") `(fg 1)) - (('glob "bg") `(bg 1)) - (('glob "jobs") `(jobs)) + ((('append ('glob "cd") arg)) `(apply chdir ,arg)) + ((('append ('glob "fg") ('glob arg))) `(fg ,(string->number arg))) + ((('append ('glob "bg") ('glob arg))) `(bg ,(string->number arg))) + ((('append ('glob "echo") args ...)) `(stdout (string-join ,@args " "))) + ((('glob "echo")) `(stdout)) + ((('glob "fg")) `(fg 1)) + ((('glob "bg")) `(bg 1)) + ((('glob "jobs")) `(jobs)) (('for-each rest ...) ast) (('if rest ...) ast) (#t #t) @@ -238,10 +238,7 @@ the GNU Public License, see COPYING for the copyleft. (define (sh-exec ast) (define (exec cmd) (local-eval cmd (the-environment))) - (let* (;;(print (format (current-error-port) "parsed: ~s\n" ast)) - (ast (transform ast)) - ;;(print (format (current-error-port) "transformed: ~s\n" ast)) - ) + (let ((ast (transform ast))) (match ast ('script #t) ;; skip (_ (begin (map exec ast) #t))))) diff --git a/gash/job.scm b/gash/job.scm index 306d3f3..f737796 100644 --- a/gash/job.scm +++ b/gash/job.scm @@ -46,7 +46,7 @@ (string-join (map (compose string-join process-command) (reverse (job-processes job))) " | ")) (define (display-job job) - (stdout "[" (job-id job) "] " (status->state (job-status job)) "\t\t" + (stdout "[" (job-id job) "] " (map status->state (job-status job)) "\t\t" (job-command job))) (define (jobs) @@ -55,7 +55,7 @@ (reverse job-table))) (define (job-status job) - (process-status (last (job-processes job)))) + (map process-status (job-processes job))) (define (job-update job pid status) (unless (= 0 pid) @@ -122,7 +122,7 @@ (unless (job-completed? job) (newline) (display-job job)) (reap-jobs) - (job-status job)) + (last (job-status job))) (define (fg index) (let ((job (job-index index))) diff --git a/gash/pipe.scm b/gash/pipe.scm index a73deb3..cae2d54 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -21,7 +21,7 @@ (define (exec* command) ;; list of strings (catch #t (lambda () (apply execlp (cons (car command) command))) - (lambda (key . args) (display (string-append (caaddr args) "\n")) + (lambda (key . args) (format (current-error-port) "~a\n" (caaddr args)) (exit #f)))) (define (setup-process fg? job) From b6c566e989d2da8fb21c22661d784ca8beabb4f7 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sat, 17 Feb 2018 21:15:41 +0100 Subject: [PATCH 073/312] support scheme in the pipeline --- gash/job.scm | 31 +++++++++++++++++++++++++------ gash/pipe.scm | 49 ++++++++++++++++++++++++++++++++++--------------- 2 files changed, 59 insertions(+), 21 deletions(-) diff --git a/gash/job.scm b/gash/job.scm index f737796..0af578d 100644 --- a/gash/job.scm +++ b/gash/job.scm @@ -7,7 +7,15 @@ :use-module (gash io) :use-module (gash util) - :export (job-control-init jobs report-jobs fg bg new-job job-add-process add-to-process-group wait)) + :export (job-control-init + jobs report-jobs + new-job + job-add-process + add-to-process-group + wait + fg + bg + setup-process)) (define-record-type (make-process pid command status) @@ -82,7 +90,7 @@ (define (job-add-process fg? job pid command) (let ((pgid (add-to-process-group job pid))) (set-job-pgid! job pgid) - (if fg? (tcsetpgrp (current-error-port) pgid)) + (when fg? (tcsetpgrp (current-error-port) pgid)) (set-job-processes! job (cons (make-process pid command #f) (job-processes job))))) (define (job-control-init) @@ -127,8 +135,9 @@ (define (fg index) (let ((job (job-index index))) (cond (job - (tcsetpgrp (current-error-port) (job-pgid job)) - (kill (- (job-pgid job)) SIGCONT) + (let ((pgid (job-pgid job))) + (tcsetpgrp (current-error-port) pgid) + (kill (- (job-pgid job)) SIGCONT)) (stdout (job-command job)) (wait job)) (#t @@ -136,5 +145,15 @@ (define (bg index) (let ((job (job-index index))) - (map (cut set-process-status! <> #f) (job-processes job)) - (kill (- (job-pgid job)) SIGCONT))) + (cond (job + (map (cut set-process-status! <> #f) (job-processes job)) + (kill (- (job-pgid job)) SIGCONT)) + (#t + (stderr "fg: no such job " index))))) + +(define (setup-process fg? job) + (when (isatty? (current-error-port)) + (when fg? (tcsetpgrp (current-error-port) (add-to-process-group job (getpid)))) + (map (cut sigaction <> SIG_DFL) + (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD))) + (fdes->inport 0) (map fdes->outport '(1 2))) ;; reset stdin/stdout/stderr diff --git a/gash/pipe.scm b/gash/pipe.scm index cae2d54..b095622 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -24,20 +24,20 @@ (lambda (key . args) (format (current-error-port) "~a\n" (caaddr args)) (exit #f)))) -(define (setup-process fg? job) - (when (isatty? (current-error-port)) - (when fg? (tcsetpgrp (current-error-port) (add-to-process-group job (getpid)))) - (map (cut sigaction <> SIG_DFL) - (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD))) - (fdes->inport 0) (map fdes->outport '(1 2))) ;; reset stdin/stdout/stderr - (define (spawn-source fg? job command) (receive (r w) (pipe*) (let ((pid (primitive-fork))) - (cond ((= 0 pid) (close r) - (setup-process fg? job) - (move->fdes w 1) - (exec* command)) + (cond ((= 0 pid) + (close r) + (setup-process fg? job) + (move->fdes w 1) + (if (procedure? command) + (begin + (close-port (current-output-port)) + (set-current-output-port w) + (command) + (exit 0)) + (exec* command))) (#t (job-add-process fg? job pid command) (close w) @@ -51,7 +51,15 @@ (if src (move->fdes src 0)) (close r) (move->fdes w 1) - (exec* command)) + (if (procedure? command) + (begin + (close-port (current-input-port)) + (close-port (current-output-port)) + (set-current-input-port src) + (set-current-output-port w) + (command) + (exit 0)) + (exec* command))) (#t (job-add-process fg? job pid command) (close w) @@ -62,7 +70,13 @@ (cond ((= 0 pid) (setup-process fg? job) (if src (move->fdes src 0)) - (exec* command)) + (if (procedure? command) + (begin + (close-port (current-input-port)) + (set-current-input-port src) + (command) + (exit 0)) + (exec* command))) (#t (job-add-process fg? job pid command) (and src (close src)))))) @@ -80,8 +94,13 @@ (spawn-sink fg? job #f (car commands))) (if fg? (wait job)))) -;;(pipeline #f (list "ls" "/")) -;;(pipeline #f (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) +;;(pipeline #t (list "sleep" "10")) +;;(pipeline #f (lambda () (display 'foo)) '("grep" "o") '("tr" "o" "e")) +(pipeline #f + (lambda () (display "bin\nboot\nroot\ntoot\nusr\nvar")) + ;;'("tr" "o" "e") + (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string)))) + (lambda () (display (read-string)) (newline))) (define (pipeline->string . commands) (let* ((fg? #f) From ca01e904d3547adbc4852c18cacf9fcf87c70df2 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Thu, 22 Feb 2018 16:17:43 +0100 Subject: [PATCH 074/312] generalize pipe for multiple in- and out-puts --- gash/pipe.scm | 98 ++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 81 insertions(+), 17 deletions(-) diff --git a/gash/pipe.scm b/gash/pipe.scm index b095622..a3564ec 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -82,25 +82,77 @@ (and src (close src)))))) -(define (pipeline fg? . commands) - (let ((job (new-job))) - (if (> (length commands) 1) - (let loop ((src (spawn-source fg? job (car commands))) - (commands (cdr commands))) - (if (null? (cdr commands)) - (spawn-sink fg? job src (car commands)) - (loop (spawn-filter fg? job src (car commands)) - (cdr commands)))) - (spawn-sink fg? job #f (car commands))) - (if fg? (wait job)))) +(define* (spawn fg? job command #:optional (input '()) (output 0)) + ;;(format #t "spawn: ~a ~a\n" (length input) output) + (let* ((ofd (iota output 1)) ;; output file descriptors 1, ... + (count (length input)) + (start (1+ output)) + (ifd (cond + ((= count 0) '()) + ((= count 1) '(0)) + ((#t (cons 0 (iota (1- count) start)))))) + (ifd (if (pair? input) (cons 0 ifd) ifd)) + ;;(foo (format #t "ifd: ~a\n" ifd)) + ;;(foo (format #t "ofd: ~a\n" ofd)) + (pipes (map (lambda (. _) (pipe)) ofd)) + (r (map car pipes)) + (w (map cdr pipes)) + (pid (primitive-fork))) + (cond ((= 0 pid) + (setup-process fg? job) + (map close r) + (map move->fdes w ofd) + (map move->fdes input ifd) + (if (procedure? command) + (begin + (when (pair? input) + (close-port (current-input-port)) + (set-current-input-port (car input))) + (when (pair? w) + (close-port (current-output-port)) + (set-current-output-port (car w))) + (command) + (exit 0)) + (exec* command))) + (#t + (job-add-process fg? job pid command) + (map close w) + r)))) -;;(pipeline #t (list "sleep" "10")) +(define (pipeline+ fg? open? . commands) + (let* ((job (new-job)) + (ports (if (> (length commands) 1) + (let loop ((input (spawn fg? job (car commands) '() 1)) ;; spawn-source + (commands (cdr commands))) + (if (null? (cdr commands)) + (spawn fg? job (car commands) input (if open? 1 0)) ;; spawn-sink + (loop (spawn fg? job (car commands) input 1) ;; spawn-filter + (cdr commands)))) + (spawn fg? job (car commands) `((current-input-port)))))) + (if fg? (wait job) (values job ports)))) + +(define (pipeline fg? . commands) + (apply pipeline+ (cons* fg? #f commands))) + +;;(pipeline #f '("head" "-c128" "/dev/urandom") '("tr" "-dc" "A-Z0-9") (lambda () (display (read-string)))) +;;(pipeline #f '("head" "-c128" "/dev/urandom") '("tr" "-dc" "A-Z0-9") '("cat")) ;;(pipeline #f (lambda () (display 'foo)) '("grep" "o") '("tr" "o" "e")) -(pipeline #f - (lambda () (display "bin\nboot\nroot\ntoot\nusr\nvar")) - ;;'("tr" "o" "e") - (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string)))) - (lambda () (display (read-string)) (newline))) + +;; (pipeline #f +;; (lambda () (display "\nbin\nboot\nroot\nusr\nvar")) +;; '("tr" "u" "a") +;; (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string)))) +;; '("cat") +;; (lambda () (display (read-string)))) + +;; (receive (job ports) +;; (pipeline+ #f #t +;; (lambda () (display "\nbin\nboot\nroot\nusr\nvar")) +;; '("tr" "u" "a") +;; (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string)))) +;; '("cat")) +;; (display (read-string (car ports)))) + (define (pipeline->string . commands) (let* ((fg? #f) @@ -117,6 +169,18 @@ (wait job) output)) +;; _ +;; \ +;; - +;; _/ + +;; (display (pipeline->string +;; (lambda () (display "\nbin\nboot\nroot\nusr\nvar")) +;; '("tr" "u" "a") +;; (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string)))) +;; '("cat") +;; (lambda () (display (read-string)) (newline)))) + (define (substitute . commands) (string-trim-right (string-map (lambda (c) From df4f7971aa1200a525d68aaa44db45fcb20a3b04 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 26 Jun 2018 20:34:07 +0200 Subject: [PATCH 075/312] updates from verum/gaiag. --- gash/gash.scm | 32 +++--- gash/io.scm | 2 +- gash/job.scm | 113 ++++++++++---------- gash/pipe.scm | 277 +++++++++++++++++++++++++------------------------- gash/util.scm | 6 +- 5 files changed, 222 insertions(+), 208 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index c384fed..b5841a6 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -1,24 +1,24 @@ (define-module (gash gash) - :use-module (srfi srfi-1) - :use-module (srfi srfi-26) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) - :use-module (ice-9 ftw) - :use-module (ice-9 getopt-long) - :use-module (ice-9 local-eval) - :use-module (ice-9 match) - :use-module (ice-9 rdelim) - :use-module (ice-9 readline) - :use-module (ice-9 buffered-input) - :use-module (ice-9 regex) + #:use-module (ice-9 ftw) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 local-eval) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 readline) + #:use-module (ice-9 buffered-input) + #:use-module (ice-9 regex) - :use-module (gash job) - :use-module (gash pipe) - :use-module (gash peg) - :use-module (gash io) - :use-module (gash util) + #:use-module (gash job) + #:use-module (gash pipe) + #:use-module (gash peg) + #:use-module (gash io) + #:use-module (gash util) - :export (main)) + #:export (main)) (define (remove-shell-comments s) (string-join (map diff --git a/gash/io.scm b/gash/io.scm index 6f64b34..e5dc37a 100644 --- a/gash/io.scm +++ b/gash/io.scm @@ -1,6 +1,6 @@ (define-module (gash io) - :export (stdout stderr)) + #:export (stdout stderr)) (define (output port o) (map (lambda (o) (display o port)) o) diff --git a/gash/job.scm b/gash/job.scm index 0af578d..c5de569 100644 --- a/gash/job.scm +++ b/gash/job.scm @@ -1,21 +1,22 @@ (define-module (gash job) - :use-module (srfi srfi-1) - :use-module (srfi srfi-8) - :use-module (srfi srfi-9) - :use-module (srfi srfi-26) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) - :use-module (gash io) - :use-module (gash util) + #:use-module (gash io) + #:use-module (gash util) - :export (job-control-init - jobs report-jobs - new-job - job-add-process - add-to-process-group - wait - fg - bg - setup-process)) + :export (bg + fg + job-add-process + job-control-init + job-debug-id + job-setup-process + jobs + new-job + report-jobs + wait)) (define-record-type (make-process pid command status) @@ -25,14 +26,21 @@ (status process-status set-process-status!)) (define-record-type - (make-job id pgid processes) + (make-job id pgid processes debug-id) job? (id job-id) (pgid job-pgid set-job-pgid!) - (processes job-processes set-job-processes!)) + (processes job-processes set-job-processes!) + (debug-id job-debug-id)) + +(define debug-id + (let ((id -1)) + (lambda () + (set! id (1+ id)) + (number->string id)))) (define (new-job) - (let ((job (make-job (+ 1 (length job-table)) #f '()))) + (let ((job (make-job (+ 1 (length job-table)) #f '() (debug-id)))) (set! job-table (cons job job-table)) job)) @@ -82,27 +90,37 @@ (every (cut member <> '(Done Terminated)) state))) (define (add-to-process-group job pid) - (let* ((pgid (job-pgid job)) - (pgid (or pgid pid))) - (setpgid pid pgid) + (let* ((interactive? (isatty? (current-error-port))) + (pgid (if interactive? + (or (job-pgid job) pid) + (getpgrp)))) + (set-job-pgid! job pgid) + (when interactive? (setpgid pid pgid)) pgid)) (define (job-add-process fg? job pid command) (let ((pgid (add-to-process-group job pid))) (set-job-pgid! job pgid) - (when fg? (tcsetpgrp (current-error-port) pgid)) + (stderr "job-add-process fg?=~a\n" fg?) + (when (and #f fg?) ;; FIXME + (tcsetpgrp (current-error-port) pgid)) (set-job-processes! job (cons (make-process pid command #f) (job-processes job))))) +(define (job-setup-process fg? job) + (when (isatty? (current-error-port)) + (when (and #f fg?) + (tcsetpgrp (current-error-port) (add-to-process-group job (getpid)))) + (map (cut sigaction <> SIG_DFL) + (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)))) + (define (job-control-init) - (let* ((interactive? (isatty? (current-error-port))) - (pgid (getpgrp)) - (pid (getpid))) - (when interactive? + (when (isatty? (current-error-port)) + (let ((pgid (getpgrp))) (while (not (eqv? (tcgetpgrp (current-error-port)) pgid)) - (kill (- pgid) SIGTTIN)) ;; oops we are not in the foreground - (map (cut sigaction <> SIG_IGN) - (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU)) - (sigaction SIGCHLD SIG_DFL) + (kill (- pgid) SIGTTIN))) ;; oops we are not in the foreground + (map (cut sigaction <> SIG_IGN) (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU)) + (sigaction SIGCHLD SIG_DFL) + (let ((pid (getpid))) (setpgid pid pid) ;; create new process group for ourself (tcsetpgrp (current-error-port) pid)))) @@ -120,24 +138,24 @@ (reap-jobs))))) (define (wait job) - (let loop () - (let* ((pid-status (waitpid (- (job-pgid job)) WUNTRACED)) - (pid (car pid-status)) - (status (cdr pid-status))) - (job-update job pid status) - (if (job-running? job) (loop)))) - (tcsetpgrp (current-error-port) (getpid)) + (when (job-running? job) + (let loop () + (let* ((pid-status (waitpid (- (job-pgid job)) WUNTRACED)) + (pid (car pid-status)) + (status (cdr pid-status))) + (job-update job pid status) + (if (job-running? job) (loop))))) (unless (job-completed? job) (newline) (display-job job)) (reap-jobs) - (last (job-status job))) + (or (and (every zero? (job-status job)) 0) 1)) (define (fg index) (let ((job (job-index index))) (cond (job (let ((pgid (job-pgid job))) - (tcsetpgrp (current-error-port) pgid) - (kill (- (job-pgid job)) SIGCONT)) + (tcsetpgrp (current-error-port) pgid) + (kill (- (job-pgid job)) SIGCONT)) (stdout (job-command job)) (wait job)) (#t @@ -146,14 +164,7 @@ (define (bg index) (let ((job (job-index index))) (cond (job - (map (cut set-process-status! <> #f) (job-processes job)) - (kill (- (job-pgid job)) SIGCONT)) - (#t - (stderr "fg: no such job " index))))) - -(define (setup-process fg? job) - (when (isatty? (current-error-port)) - (when fg? (tcsetpgrp (current-error-port) (add-to-process-group job (getpid)))) - (map (cut sigaction <> SIG_DFL) - (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD))) - (fdes->inport 0) (map fdes->outport '(1 2))) ;; reset stdin/stdout/stderr + (map (cut set-process-status! <> #f) (job-processes job)) + (kill (- (job-pgid job)) SIGCONT)) + (#t + (stderr "fg: no such job " index))))) diff --git a/gash/pipe.scm b/gash/pipe.scm index a3564ec..1ea845a 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -1,173 +1,176 @@ (define-module (gash pipe) - :use-module (ice-9 popen) - :use-module (ice-9 rdelim) + #:use-module (ice-9 curried-definitions) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) - :use-module (srfi srfi-1) - :use-module (srfi srfi-8) - :use-module (srfi srfi-9) - :use-module (srfi srfi-26) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) - :use-module (gash job) + #:use-module (gash job) + #:use-module (gash io) - :export (pipeline substitute)) + #:export (handle-error pipeline pipeline->string substitute)) + +;; TODO +(define %debug-level 0) + +(define (handle-error job error) + (let ((status (wait job))) + (when (not (zero? status)) + (format (current-error-port) "ERROR: exit: ~a: ~s" status error) + (exit status)) + status)) (define (pipe*) (let ((p (pipe))) (values (car p) (cdr p)))) ;; lhs rhs -;; [source] w -> r [filter] w -> r [sink] +;; [source] w[1] -> r[0] [filter] w[1] -> r[0] [sink] +;; w[2] -> r[3] [sink] (define (exec* command) ;; list of strings (catch #t (lambda () (apply execlp (cons (car command) command))) (lambda (key . args) (format (current-error-port) "~a\n" (caaddr args)) (exit #f)))) -(define (spawn-source fg? job command) - (receive (r w) (pipe*) - (let ((pid (primitive-fork))) - (cond ((= 0 pid) - (close r) - (setup-process fg? job) - (move->fdes w 1) - (if (procedure? command) - (begin - (close-port (current-output-port)) - (set-current-output-port w) - (command) - (exit 0)) - (exec* command))) - (#t - (job-add-process fg? job pid command) - (close w) - r))))) +(define ((tee-n file-names) inputs outputs) + (let* ((files (map open-output-file file-names)) + (tees (zip files inputs outputs))) + (let loop ((tees tees)) + (loop (filter-map (lambda (tee) + (let ((file (first tee)) + (input (second tee)) + (output (third tee))) + (when (char-ready? input) + (let ((char (read-char input))) + (if (not (eof-object? char)) + (begin (display char file) + (display char output) + (list file input output)) + #f))))) + tees))) + (map close outputs))) -(define (spawn-filter fg? job src command) - (receive (r w) (pipe*) - (let ((pid (primitive-fork))) - (cond ((= 0 pid) - (setup-process fg? job) - (if src (move->fdes src 0)) - (close r) - (move->fdes w 1) - (if (procedure? command) - (begin - (close-port (current-input-port)) - (close-port (current-output-port)) - (set-current-input-port src) - (set-current-output-port w) - (command) - (exit 0)) - (exec* command))) - (#t - (job-add-process fg? job pid command) - (close w) - r))))) - -(define (spawn-sink fg? job src command) - (let ((pid (primitive-fork))) +(define* (spawn fg? job command #:optional (input '())) + ;;(format #t "spawn: ~a\n" (length input)) + (let* ((ofd '(1 2)) ;; output file descriptors 1, ... + (ifd (cond + ((= (length input) 0) '()) + ((= (length input) 1) '(0)))) + (pipes (map (lambda (. _) (pipe)) ofd)) + (r (map car pipes)) + (w (map cdr pipes)) + (pid (primitive-fork))) + ;;(format (current-error-port) "INPUT: ~a\n" (length input)) + ;;(format (current-error-port) "OUTPUT: ~a\n" (length w)) (cond ((= 0 pid) - (setup-process fg? job) - (if src (move->fdes src 0)) - (if (procedure? command) - (begin - (close-port (current-input-port)) - (set-current-input-port src) - (command) - (exit 0)) - (exec* command))) + (job-setup-process fg? job) + (map close r) + (if (procedure? command) + (begin + (when (pair? input) + (close-port (current-input-port)) + (set-current-input-port (car input))) + (when (pair? w) + (close-port (current-output-port)) + (set-current-output-port (car w))) + ;;(format (current-error-port) "INPUT: ~a\n" (length input)) + ;;(format (current-error-port) "OUTPUT: ~a\n" (length w)) + (if (thunk? command) (command) + (command input w)) + (exit 0)) + (begin + (map dup->fdes w ofd) + (map dup->fdes input ifd) + (exec* command)))) (#t (job-add-process fg? job pid command) - (and src (close src)))))) - - -(define* (spawn fg? job command #:optional (input '()) (output 0)) - ;;(format #t "spawn: ~a ~a\n" (length input) output) - (let* ((ofd (iota output 1)) ;; output file descriptors 1, ... - (count (length input)) - (start (1+ output)) - (ifd (cond - ((= count 0) '()) - ((= count 1) '(0)) - ((#t (cons 0 (iota (1- count) start)))))) - (ifd (if (pair? input) (cons 0 ifd) ifd)) - ;;(foo (format #t "ifd: ~a\n" ifd)) - ;;(foo (format #t "ofd: ~a\n" ofd)) - (pipes (map (lambda (. _) (pipe)) ofd)) - (r (map car pipes)) - (w (map cdr pipes)) - (pid (primitive-fork))) - (cond ((= 0 pid) - (setup-process fg? job) - (map close r) - (map move->fdes w ofd) - (map move->fdes input ifd) - (if (procedure? command) - (begin - (when (pair? input) - (close-port (current-input-port)) - (set-current-input-port (car input))) - (when (pair? w) - (close-port (current-output-port)) - (set-current-output-port (car w))) - (command) - (exit 0)) - (exec* command))) - (#t - (job-add-process fg? job pid command) - (map close w) - r)))) - -(define (pipeline+ fg? open? . commands) - (let* ((job (new-job)) - (ports (if (> (length commands) 1) - (let loop ((input (spawn fg? job (car commands) '() 1)) ;; spawn-source - (commands (cdr commands))) - (if (null? (cdr commands)) - (spawn fg? job (car commands) input (if open? 1 0)) ;; spawn-sink - (loop (spawn fg? job (car commands) input 1) ;; spawn-filter - (cdr commands)))) - (spawn fg? job (car commands) `((current-input-port)))))) - (if fg? (wait job) (values job ports)))) + (map close w) + r)))) (define (pipeline fg? . commands) - (apply pipeline+ (cons* fg? #f commands))) + (when (> %debug-level 0) + (format (current-error-port) "pipeline[~a]: COMMANDS: ~s\n" fg? commands)) + (receive (r w) + (pipe*) + (move->fdes w 2) + (let* ((error-port (set-current-error-port w)) + (job (new-job)) + (debug-id (job-debug-id job)) + (commands + (if (zero? %debug-level) commands + (fold-right (lambda (command id lst) + (let ((file (string-append debug-id "." id))) + (cons* command `("tee" ,file) lst))) + '() commands (map number->string (iota (length commands)))))) + (foo (when (> %debug-level 0) (with-output-to-file debug-id (cut format #t "COMMANDS: ~s\n" commands)))) + (ports (if (> (length commands) 1) + (let loop ((input (spawn fg? job (car commands) '())) ;; spawn-source + (commands (cdr commands))) + (if (null? (cdr commands)) + (spawn fg? job (car commands) input) ;; spawn-sink + (loop (spawn fg? job (car commands) input) ;; spawn-filter + (cdr commands)))) + (spawn fg? job (car commands) '())))) ;; spawn-sink + (when fg? + (let loop ((input ports) + (output (list (current-output-port) error-port))) + (let ((line (map read-line input))) + (let* ((input-available? (lambda (o ln) (and (not (eof-object? ln)) o))) + (line (filter-map input-available? line line)) + (output (filter-map input-available? output line)) + (input (filter-map input-available? input line))) + (when (pair? input) + (map display line output) + (map newline output) + (loop input output))))) + (wait job)) + (move->fdes error-port 2) + (set-current-error-port error-port) + (close w) + (values job (append ports (list r)))))) + +(define (pipeline->string . commands) + (receive (job ports) + (apply pipeline #f commands) + (let ((output (read-string (car ports)))) + (wait job) + output))) ;;(pipeline #f '("head" "-c128" "/dev/urandom") '("tr" "-dc" "A-Z0-9") (lambda () (display (read-string)))) ;;(pipeline #f '("head" "-c128" "/dev/urandom") '("tr" "-dc" "A-Z0-9") '("cat")) ;;(pipeline #f (lambda () (display 'foo)) '("grep" "o") '("tr" "o" "e")) ;; (pipeline #f -;; (lambda () (display "\nbin\nboot\nroot\nusr\nvar")) -;; '("tr" "u" "a") -;; (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string)))) -;; '("cat") -;; (lambda () (display (read-string)))) +;; (lambda () (display "\nbin\nboot\nroot\nusr\nvar")) +;; '("tr" "u" "a") +;; (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string)))) +;; '("cat") +;; (lambda () (display (read-string)))) ;; (receive (job ports) -;; (pipeline+ #f #t -;; (lambda () (display "\nbin\nboot\nroot\nusr\nvar")) -;; '("tr" "u" "a") -;; (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string)))) -;; '("cat")) -;; (display (read-string (car ports)))) +;; (pipeline #f +;; (lambda () +;; (display "foo") +;; (display "bar" (current-error-port))) +;; '("tr" "o" "e")) +;; (map (compose display read-string) ports)) +;; _ +;; \ +;; - +;; _/ -(define (pipeline->string . commands) - (let* ((fg? #f) - (job (new-job)) - (output (read-string - (if (> (length commands) 1) - (let loop ((src (spawn-source fg? job (car commands))) - (commands (cdr commands))) - (if (null? (cdr commands)) - (spawn-filter fg? job src (car commands)) - (loop (spawn-filter fg? job src (car commands)) - (cdr commands)))) - (spawn-filter fg? job #f (car commands)))))) - (wait job) - output)) +;; (display (pipeline->string +;; (lambda () (display "\nbin\nboot\nroot\nusr\nvar")) +;; '("tr" "u" "a") +;; (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string)))) +;; '("cat") +;; (lambda () (display (read-string)) (newline)))) ;; _ ;; \ diff --git a/gash/util.scm b/gash/util.scm index a0ecc52..ce1c8b5 100644 --- a/gash/util.scm +++ b/gash/util.scm @@ -1,8 +1,8 @@ (define-module (gash util) - :use-module (srfi srfi-1) - :use-module (srfi srfi-26) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) - :export (disjoin conjoin)) + #:export (disjoin conjoin)) (define (disjoin . predicates) (lambda (. arguments) From cd4a80d3cb2cf9478be6ff8abbaf18637f269755 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 29 Jun 2018 18:43:58 +0200 Subject: [PATCH 076/312] build: add makefile, build bin/gash * bin/gash.in: New file. * bin/gash: Remove * makefile: New file. --- .gitignore | 3 +++ bin/gash | 1 - bin/gash.in | 5 +++++ makefile | 10 ++++++++++ 4 files changed, 18 insertions(+), 1 deletion(-) create mode 100644 .gitignore delete mode 100755 bin/gash create mode 100644 bin/gash.in create mode 100644 makefile diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..04fd279 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +*.go +*~ +/bin/gash diff --git a/bin/gash b/bin/gash deleted file mode 100755 index 45aae8b..0000000 --- a/bin/gash +++ /dev/null @@ -1 +0,0 @@ -guile -L $(dirname $0)/.. -e '(@ (gash gash) main)' -s $(dirname $0)/../gash/gash.scm $* diff --git a/bin/gash.in b/bin/gash.in new file mode 100644 index 0000000..40b5f04 --- /dev/null +++ b/bin/gash.in @@ -0,0 +1,5 @@ +#!@GUILE@ \ +-L . --no-auto-compile -s +!# +(setenv "SHELL" ((compose canonicalize-path car command-line))) +((@ (gash gash) main) (command-line)) diff --git a/makefile b/makefile new file mode 100644 index 0000000..915aa0a --- /dev/null +++ b/makefile @@ -0,0 +1,10 @@ +all: bin/gash + +GUILE = $(shell $(SHELL) -c "command -v guile") + +bin/gash: bin/gash.in + sed s,@GUILE@,$(GUILE), $< > $@ + chmod +x $@ + +clean: + rm -f bin/gash From 7b9871478b573e14fa94a84f3585c2cbed6f02a3 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 29 Jun 2018 18:57:41 +0200 Subject: [PATCH 077/312] build: add ./configure, compile .go files. * configure: New file. * build-aux/build-guile.sh: New file. * makefile (all-go): New target. --- .gitignore | 1 + bin/gash.in | 16 +++++++--- build-aux/build-guile.sh | 68 ++++++++++++++++++++++++++++++++++++++++ configure | 39 +++++++++++++++++++++++ makefile | 55 +++++++++++++++++++++++++++++--- 5 files changed, 170 insertions(+), 9 deletions(-) create mode 100755 build-aux/build-guile.sh create mode 100755 configure diff --git a/.gitignore b/.gitignore index 04fd279..301bb29 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ *.go *~ /bin/gash +/.config.make \ No newline at end of file diff --git a/bin/gash.in b/bin/gash.in index 40b5f04..4321d28 100644 --- a/bin/gash.in +++ b/bin/gash.in @@ -1,5 +1,13 @@ -#!@GUILE@ \ --L . --no-auto-compile -s +#! /bin/sh +# -*-scheme-*- +exec ${GUILE-guile} -L $(pwd)/bin -L $(pwd) -C $(pwd)/bin -C $(pwd) --no-auto-compile -e '(gash)' -s $0 $@ !# -(setenv "SHELL" ((compose canonicalize-path car command-line))) -((@ (gash gash) main) (command-line)) +(define-module (gash) + #:export (main)) + +(set! %load-path (append '("@GUILE_SITE_DIR@") %load-path)) +(set! %load-compiled-path (append '("@GUILE_SITE_CCACHE_DIR@") %load-compiled-path)) + +(define (main args) + (setenv "SHELL" ((compose canonicalize-path car command-line))) + ((@ (gash gash) main) (command-line))) diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh new file mode 100755 index 0000000..d499bfc --- /dev/null +++ b/build-aux/build-guile.sh @@ -0,0 +1,68 @@ +#! /bin/sh + +# Gash --- Guile As SHell +# Copyright © 2018 Jan (janneke) Nieuwenhuizen +# +# This file is part of Gash. +# +# Gash is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or (at +# your option) any later version. +# +# Gash is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Gash. If not, see . + +if [ -n "$BUILD_DEBUG" ]; then + set -x +fi + +export GUILE +export GUILE_AUTO_COMPILE +export GUILE_LOAD_PATH +export GUILE_LOAD_COMPILED_PATH + +GUILE_LOAD_PATH=$(pwd):$GUILE_LOAD_PATH +GUILE_LOAD_COMPILED_PATH=$(pwd):$GUILE_LOAD_COMPILED_PATH +GUILE=${GUILE-$(command -v guile)} +GUILE_TOOLS=${GUILE_TOOLS-$(command -v guile-tools)} +GUILE_AUTO_COMPILE=0 + +set -e + +SCM_FILES=" +gash/gash.scm +gash/io.scm +gash/job.scm +gash/peg.scm +gash/pipe.scm +gash/util.scm +" + +export srcdir=. +export host=$($GUILE -c "(display %host-type)") + +for i in $SCM_FILES; do + go=${i%%.scm}.go + if [ $i -nt $go ]; then + echo " GUILEC $i" + $GUILE_TOOLS compile -L bin -L gash -o $go $i + fi +done + +SCRIPTS=" +bin/gash +" + +for i in $SCRIPTS; do + go=${i%%.scm}.go + if [ $i -nt $go ]; then + echo " GUILEC $i" + $GUILE_TOOLS compile -L guile -L scripts -o $go $i + fi +done diff --git a/configure b/configure new file mode 100755 index 0000000..5c038d6 --- /dev/null +++ b/configure @@ -0,0 +1,39 @@ +#! /bin/sh + +# parse --prefix=PREFIX, mainly for GuixSD/Debian +cmdline=$(echo "$@") +PREFIX=${cmdline##*--prefix=} +PREFIX=${PREFIX% *} +PREFIX=${PREFIX% -*} +if [ -z "$PREFIX" ]; then + PREFIX=/usr/local +fi + +GUILE=$(command -v guile) +GUILE_TOOLS=$(command -v guile-tools) +GUILE_SITE_DIR=$PREFIX/share/guile/site/$GUILE_EFFECTIVE_VERSION +GUILE_SITE_CCACHE_DIR=$PREFIX/lib/guile/$GUILE_EFFECTIVE_VERSION/site-ccache +GUILE_EFFECTIVE_VERSION=$(guile -c '(display (effective-version))') + +sed \ + -e s,@GUILE@,$GUILE,\ + -e s,@GUILE_SITE_DIR@,$GUILE_SITE_DIR,\ + -e s,@GUILE_SITE_CCACHE_DIR@,$GUILE_SITE_CCACHE_DIR,\ + bin/gash.in > bin/gash +chmod +x bin/gash +cat > .config.make < $@ - chmod +x $@ + ./configure --prefix=$(PREFIX) + +all: all-go bin/gash + +all-go: + build-aux/build-guile.sh clean: - rm -f bin/gash + git clean -fdx + +clean-go: + rm -f $(shell find . -name '*.go') + +check: all + echo TODO + +install: all + mkdir -p $(DESTDIR)$(BINDIR) + cp bin/gash $(DESTDIR)$(BINDIR)/gash + mkdir -p $(DESTDIR)$(GUILE_SITE_DIR) + tar -cf- gash/*.scm | tar -C $(DESTDIR)$(GUILE_SITE_DIR) -xf- + mkdir -p $(DESTDIR)$(GUILE_SITE_CCACHE_DIR) + cp bin/gash.go $(DESTDIR)$(GUILE_SITE_CCACHE_DIR) + tar -cf- gash/*.go | tar -C $(DESTDIR)$(GUILE_SITE_CCACHE_DIR) -xf- + mkdir -p $(DESTDIR)$(DOCDIR) + cp -f COPYING README TODO $(DOCDIR) + +define HELP_TOP +Usage: make [OPTION]... [TARGET]... + +Targets: + all update everything + all-go update .go files + clean run git clean -dfx + clean-go clean .go files + install install in $(PREFIX) +endef +export HELP_TOP +help: + @echo "$$HELP_TOP" + +export GUILE +export GUILE_TOOLS +export GUILE_LOAD_PATH +export GUILE_LOAD_COMPILED_PATH + From fbe9747d0043dec8a9a012bf1aff2a54391a7ebb Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 29 Jun 2018 20:06:22 +0200 Subject: [PATCH 078/312] guix: Add guix package build. * guix.scm: New file. --- guix.scm | 122 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 122 insertions(+) create mode 100644 guix.scm diff --git a/guix.scm b/guix.scm new file mode 100644 index 0000000..ef6e48f --- /dev/null +++ b/guix.scm @@ -0,0 +1,122 @@ +;;; guix.scm -- Guix package definition + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen + +;;; Also borrowing code from: +;;; guile-sdl2 --- FFI bindings for SDL2 +;;; Copyright © 2015 David Thompson + +;;; +;;; guix.scm: This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +;;; Commentary: +;; +;; GNU Guix development package. To build and install, run: +;; +;; guix package -f guix.scm +;; +;; To build it, but not install it, run: +;; +;; guix build -f guix.scm +;; +;; To use as the basis for a development environment, run: +;; +;; guix environment -l guix.scm +;; +;;; Code: + +(use-modules (srfi srfi-1) + (srfi srfi-26) + (ice-9 match) + (ice-9 popen) + (ice-9 rdelim) + (gnu packages) + (gnu packages base) + (gnu packages commencement) + (gnu packages cross-base) + (gnu packages gcc) + (gnu packages guile) + (gnu packages mes) + (gnu packages package-management) + (gnu packages perl) + ((guix build utils) #:select (with-directory-excursion)) + (guix build-system gnu) + (guix build-system trivial) + (guix gexp) + (guix download) + (guix git-download) + (guix licenses) + (guix packages)) + +(define %source-dir (dirname (current-filename))) + +(define git-file? + (let* ((pipe (with-directory-excursion %source-dir + (open-pipe* OPEN_READ "git" "ls-files"))) + (files (let loop ((lines '())) + (match (read-line pipe) + ((? eof-object?) + (reverse lines)) + (line + (loop (cons line lines)))))) + (status (close-pipe pipe))) + (lambda (file stat) + (match (stat:type stat) + ('directory #t) + ((or 'regular 'symlink) + (any (cut string-suffix? <> file) files)) + (_ #f))))) + +(define-public gash + (let ((commit "7b9871478b573e14fa94a84f3585c2cbed6f02a3") + (revision "0") + (version "0.1")) + (package + (name "gash") + (version (string-append version "-" revision "." (string-take commit 7))) + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://gitlab.com/janneke/gash") + (commit commit))) + (file-name (string-append name "-" version)) + (sha256 + (base32 "11708vl2f04xpgs57mac4z7illx6wf4ybb32mh9ajfwimlkvwl4f")))) + (build-system gnu-build-system) + (inputs + `(("guile" ,guile-2.2) + ("guile-readline" ,guile-readline))) + (synopsis "A POSIX compliant sh replacement for Guile.") + (description + "Gash [Guile As Shell] aims to produce at least a POSIX compliant sh replacement +or even implement GNU bash. On top of that it also intends to make +scheme available for interactive and scripting application.") + (home-page "https://gitlab.com/rutger.van.beusekom/gash") + (license gpl3+)))) + +(define-public gash.git + (let ((version "0.1") + (revision "0") + (commit (read-string (open-pipe "git show HEAD | head -1 | cut -d ' ' -f 2" OPEN_READ)))) + (package + (inherit gash) + (name "gash.git") + (version (string-append version "-" revision "." (string-take commit 7))) + (source (local-file %source-dir #:recursive? #t #:select? git-file?))))) + +;; Return it here so `guix build/environment/package' can consume it directly. +gash.git From a14c7c7360a440f320963f5d7f29b7808bc5911a Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 30 Jun 2018 06:35:36 +0200 Subject: [PATCH 079/312] Use pretty-print to display error tree. * gash/peg.scm (parse): Use pretty-print to display error tree. (parse-): Likewise. --- gash/peg.scm | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/gash/peg.scm b/gash/peg.scm index e1b7ced..c3283d2 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -1,8 +1,9 @@ (define-module (gash peg) - :use-module (ice-9 peg) - :use-module (ice-9 peg codegen) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 peg) + #:use-module (ice-9 peg codegen) - :export (parse peg-trace?)) + #:export (parse peg-trace?)) (define (error? x) (let loop ((x x)) @@ -15,7 +16,8 @@ (define (parse input) (let ((tree (parse- input))) (cond ((error? tree) - (format (current-error-port) "error: ~a\n" tree) + (format (current-error-port) "error:\n") + (pretty-print tree (current-error-port)) #f) (#t tree)))) @@ -104,7 +106,8 @@ tree (if match (begin - (format (current-error-port) "parse error: at offset: ~a\n~s\n" end tree) + (format (current-error-port) "parse error: at offset: ~a\n" end) + (pretty-print tree (current-error-port)) #f) (begin (format (current-error-port) "parse error: no match\n") From 1562ef93cbf568a543f52f7c443930223906ee92 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 30 Jun 2018 06:37:20 +0200 Subject: [PATCH 080/312] guix: Propagate guile-readline. * guix.scm (gash): Propagate guile-readline. --- guix.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/guix.scm b/guix.scm index ef6e48f..8926746 100644 --- a/guix.scm +++ b/guix.scm @@ -97,9 +97,10 @@ (sha256 (base32 "11708vl2f04xpgs57mac4z7illx6wf4ybb32mh9ajfwimlkvwl4f")))) (build-system gnu-build-system) + (propagated-inputs + `(("guile-readline" ,guile-readline))) (inputs - `(("guile" ,guile-2.2) - ("guile-readline" ,guile-readline))) + `(("guile" ,guile-2.2))) (synopsis "A POSIX compliant sh replacement for Guile.") (description "Gash [Guile As Shell] aims to produce at least a POSIX compliant sh replacement From 1b56f8cb2fc110a86b959cf9f6fc3de723b54588 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 30 Jun 2018 07:05:57 +0200 Subject: [PATCH 081/312] BUGS: New file. Fixed one. --- BUGS | 13 +++++++++++++ gash/gash.scm | 17 +++++++++-------- 2 files changed, 22 insertions(+), 8 deletions(-) create mode 100644 BUGS diff --git a/BUGS b/BUGS new file mode 100644 index 0000000..183467e --- /dev/null +++ b/BUGS @@ -0,0 +1,13 @@ + -*- org -*- +* TODO +** gash -c STRING +** bin/gash --debug --parse <(echo done) +** bin/gash <(echo 'echo "$foo"') +prints: $bar +** bin/gash <(echo 'echo "foo=$bar"') +prints: foo=$bar +** bin/gash <(echo 'echo "foo:$bar"') +prints: foo:$bar + +* DONE +** bin/gash --debug --parse <(echo 'foo=`eval echo $bar`') diff --git a/gash/gash.scm b/gash/gash.scm index b5841a6..2c1af25 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -158,14 +158,15 @@ the GNU Public License, see COPYING for the copyleft. (cute glob-match (glob2regex pattern) <>)) (or (scandir path) '())))) paths))) - (if (glob? pattern) - (let ((absolute? (string-prefix? "/" pattern))) - (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) - (paths (if absolute? '("/") '(".")))) - (if (null? patterns) - paths - (loop (cdr patterns) (glob- (car patterns) paths))))) - (list pattern))) + (if (not pattern) '("") + (if (glob? pattern) + (let ((absolute? (string-prefix? "/" pattern))) + (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) + (paths (if absolute? '("/") '(".")))) + (if (null? patterns) + paths + (loop (cdr patterns) (glob- (car patterns) paths))))) + (list pattern)))) (define (background ast) (match ast From e3d564fc4c1590969af3675a311e7061ac29f114 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sun, 1 Jul 2018 14:04:23 +0200 Subject: [PATCH 082/312] fix spawn to use no input or just the first --- gash/pipe.scm | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/gash/pipe.scm b/gash/pipe.scm index 1ea845a..e669daa 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -56,17 +56,14 @@ (map close outputs))) (define* (spawn fg? job command #:optional (input '())) - ;;(format #t "spawn: ~a\n" (length input)) - (let* ((ofd '(1 2)) ;; output file descriptors 1, ... + (let* ((ofd '(1 2)) ;; output file descriptors 1 & 2 (ifd (cond - ((= (length input) 0) '()) - ((= (length input) 1) '(0)))) + ((null? input) '()) + (#t '(0)))) ;;support no input or 1 input, TODO multiple inputs (pipes (map (lambda (. _) (pipe)) ofd)) (r (map car pipes)) (w (map cdr pipes)) (pid (primitive-fork))) - ;;(format (current-error-port) "INPUT: ~a\n" (length input)) - ;;(format (current-error-port) "OUTPUT: ~a\n" (length w)) (cond ((= 0 pid) (job-setup-process fg? job) (map close r) @@ -78,8 +75,6 @@ (when (pair? w) (close-port (current-output-port)) (set-current-output-port (car w))) - ;;(format (current-error-port) "INPUT: ~a\n" (length input)) - ;;(format (current-error-port) "OUTPUT: ~a\n" (length w)) (if (thunk? command) (command) (command input w)) (exit 0)) From 32f1d25170db1e76483f7950d4b2f52cc072bcd0 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Mon, 2 Jul 2018 08:35:10 +0200 Subject: [PATCH 083/312] add -c STRING --- BUGS | 2 +- bin/gash.in | 2 +- gash/gash.scm | 15 +++++++++------ 3 files changed, 11 insertions(+), 8 deletions(-) diff --git a/BUGS b/BUGS index 183467e..87b2c29 100644 --- a/BUGS +++ b/BUGS @@ -1,6 +1,5 @@ -*- org -*- * TODO -** gash -c STRING ** bin/gash --debug --parse <(echo done) ** bin/gash <(echo 'echo "$foo"') prints: $bar @@ -11,3 +10,4 @@ prints: foo:$bar * DONE ** bin/gash --debug --parse <(echo 'foo=`eval echo $bar`') +** gash -c STRING diff --git a/bin/gash.in b/bin/gash.in index 4321d28..9e7f52c 100644 --- a/bin/gash.in +++ b/bin/gash.in @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -exec ${GUILE-guile} -L $(pwd)/bin -L $(pwd) -C $(pwd)/bin -C $(pwd) --no-auto-compile -e '(gash)' -s $0 $@ +exec ${GUILE-guile} -L $(pwd)/bin -L $(pwd) -C $(pwd)/bin -C $(pwd) --no-auto-compile -e '(gash)' -s $0 "$@" !# (define-module (gash) #:export (main)) diff --git a/gash/gash.scm b/gash/gash.scm index 2c1af25..3edf0ed 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -77,28 +77,31 @@ the GNU Public License, see COPYING for the copyleft. (let ((thunk (lambda () (job-control-init) - (let* ((option-spec '((debug (single-char #\d) (value #f)) + (let* ((option-spec '((command (single-char #\c) (value #t)) + (debug (single-char #\d) (value #f)) (help (single-char #\h) (value #f)) (parse (single-char #\p) (value #f)) (version (single-char #\v) (value #f)))) - (options (getopt-long args option-spec - #:stop-at-first-non-option #t )) + (options (getopt-long args option-spec #:stop-at-first-non-option #t )) + (command? (option-ref options 'command #f)) (help? (option-ref options 'help #f)) - (parse? (option-ref options 'parse (null? #f))) + (parse? (option-ref options 'parse #f)) (version? (option-ref options 'version #f)) (files (option-ref options '() '())) (run (lambda (ast) (cond (parse? (let ((ast- (transform ast))) - (format (current-output-port) "parsed : ~s\n\n" ast) - (format (current-output-port) "prepared : ~s\n\n" ast-) + (stdout "parsed: " ast) + (stdout "prepared: " ast-) #t)) (#t (sh-exec ast)))))) (cond (help? (display-help)) (version? (display-version)) + (command? (let ((ast (string-to-ast command?))) + (when ast (run ast)))) ((pair? files) (let* ((asts (map file-to-ast files)) (status (map run asts))) From 01bfb484dc2fc0c39a3e89fd070c8c17b57400ad Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Mon, 2 Jul 2018 08:39:24 +0200 Subject: [PATCH 084/312] allow reserved words "everywhere" --- gash/peg.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gash/peg.scm b/gash/peg.scm index c3283d2..8099960 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -65,7 +65,7 @@ brace-group <-- '{' (sp* (compound-list / error) sp* '}' / error) simple-command <-- (io-redirect sp+)* nonreserved (sp+ (io-redirect / nonreserved))* reserved < 'case' / 'esac' / 'if' / 'fi' / 'then' / 'else' / 'elif' / 'for' / 'done' / 'do' / 'until' / 'while' - nonreserved <- &(reserved word) word / !reserved word + nonreserved <- &(reserved word) word / !reserved word / word io-redirect <-- [0-9]* sp* (io-here / io-file) io-file <-- ('<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|') sp* ([0-9]+ / filename) io-here <- ('<<' / '<<-') io-suffix here-document From d79936f561b3b13f24a0fa25d2a6e93041dfe50f Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 2 Jul 2018 18:04:13 +0200 Subject: [PATCH 085/312] Refactor builtin commands. * gash/gash.scm (main): Handle --prefer-builtins. (display-help): Mention it. (bg-command, cd-command, echo-command, pwd-command, fg-command): New functions. (%commands): New variable. (builtin): Use it. --- gash/gash.scm | 103 +++++++++++++++++++++++++++++++++++++++++--------- gash/job.scm | 8 ++-- 2 files changed, 88 insertions(+), 23 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index 3edf0ed..8ad33e8 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -10,6 +10,7 @@ #:use-module (ice-9 rdelim) #:use-module (ice-9 readline) #:use-module (ice-9 buffered-input) + #:use-module (ice-9 receive) #:use-module (ice-9 regex) #:use-module (gash job) @@ -48,10 +49,11 @@ (define (display-help) (display "\ gash [options] - -d, --debug Enable PEG tracing - -h, --help Display this help - -p, --parse Parse the shell script and print the parse tree - -v, --version Display the version + -d, --debug Enable PEG tracing + -h, --help Display this help + -p, --parse Parse the shell script and print the parse tree + --prefer-builtins Use builtins, even if command is available in PATH + -v, --version Display the version ")) (define (display-version) @@ -81,6 +83,7 @@ the GNU Public License, see COPYING for the copyleft. (debug (single-char #\d) (value #f)) (help (single-char #\h) (value #f)) (parse (single-char #\p) (value #f)) + (prefer-builtins) (version (single-char #\v) (value #f)))) (options (getopt-long args option-spec #:stop-at-first-non-option #t )) (command? (option-ref options 'command #f)) @@ -97,6 +100,7 @@ the GNU Public License, see COPYING for the copyleft. #t)) (#t (sh-exec ast)))))) + (set! %prefer-builtins? (option-ref options 'prefer-builtins #f)) (cond (help? (display-help)) (version? (display-version)) @@ -176,21 +180,84 @@ the GNU Public License, see COPYING for the copyleft. (('pipeline fg rest ...) `(pipeline #f ,@rest)) (_ ast))) +(define (PATH-search-path program) + (search-path (string-split (getenv "PATH") #\:) program)) + +(define (cd-command . args) + (match args + (() (chdir (getenv "HOME"))) + ((dir) + (chdir dir)) + ((args ...) + (format (current-error-port) "cd: too many arguments: ~a\n" (string-join args))))) + +(define (echo-command . args) + (match args + (() (newline)) + (("-n" args ...) (display (string-join args))) + (_ (stdout (string-join args))))) + +(define (bg-command . args) + (match args + (() (bg 1)) + ((job x ...) (bg (string->number (car job)))))) + +(define (fg-command . args) + (match args + (() (fg 1)) + ((job x ...) (fg (string->number (car job)))))) + +(define pwd-command (lambda _ (stdout (getcwd)))) + + +(define %commands + ;; Built-in commands. + `( + ("echo" . ,echo-command) + ("cd" . ,cd-command) + ("pwd" . ,pwd-command) + ("jobs" . ,jobs-command) + ("bg" . ,bg-command) + ("fg" . ,fg-command) + + ;; Bournish + ;; ("echo" ,(lambda strings `(list ,@strings))) + ;; ("cd" ,(lambda (dir) `(chdir ,dir))) + ;; ("pwd" ,(lambda () `(getcwd))) + ;; ("rm" ,rm-command) + ;; ("cp" ,(lambda (source dest) `(copy-file ,source ,dest))) + ;; ("help" ,help-command) + ;; ("ls" ,ls-command) + ;; ("which" ,which-command) + ;; ("cat" ,cat-command) + ;; ("wc" ,wc-command) + ;; ("reboot" ,reboot-command) + + )) + +(define %prefer-builtins? #t) ; use builtin, even if COMMAND is available in PATH? (define (builtin ast) - ;;(stdout "builtin: " ast "\n") - (match ast - ((('append ('glob "cd") arg)) `(apply chdir ,arg)) - ((('append ('glob "fg") ('glob arg))) `(fg ,(string->number arg))) - ((('append ('glob "bg") ('glob arg))) `(bg ,(string->number arg))) - ((('append ('glob "echo") args ...)) `(stdout (string-join ,@args " "))) - ((('glob "echo")) `(stdout)) - ((('glob "fg")) `(fg 1)) - ((('glob "bg")) `(bg 1)) - ((('glob "jobs")) `(jobs)) - (('for-each rest ...) ast) - (('if rest ...) ast) - (#t #t) - (_ #f))) + (receive (command args) + (match ast + ((('append ('glob command) args ...)) (values command args)) + ((('glob command)) (values command #f)) + (_ (values #f #f))) + (let ((program (and command (PATH-search-path command)))) + (format (current-error-port) "command ~a => ~s ~s\n" program command args) + (cond ((and program (not %prefer-builtins?)) + #f) + ((and command (assoc-ref %commands command)) + => + (lambda (command) + (if args + `(,apply ,command ,@args) + `(,command)))) + (else + (match ast + (('for-each rest ...) ast) + (('if rest ...) ast) + (#t #t) + (_ #f))))))) ;; transform ast -> list of expr ;; such that (map eval expr) diff --git a/gash/job.scm b/gash/job.scm index c5de569..be3954e 100644 --- a/gash/job.scm +++ b/gash/job.scm @@ -13,7 +13,7 @@ job-control-init job-debug-id job-setup-process - jobs + jobs-command new-job report-jobs wait)) @@ -65,10 +65,8 @@ (stdout "[" (job-id job) "] " (map status->state (job-status job)) "\t\t" (job-command job))) -(define (jobs) - (map (lambda (job) - (display-job job)) - (reverse job-table))) +(define (jobs-command) + (for-each (lambda (job) (display-job job)) (reverse job-table))) (define (job-status job) (map process-status (job-processes job))) From 462f8ce95fee3473e117c2b6fae4d8a31ad98bfd Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 2 Jul 2018 19:03:21 +0200 Subject: [PATCH 086/312] handle exit stati WIP --- gash/gash.scm | 19 +++++++++++++++++-- gash/job.scm | 25 ++++++++++++++----------- gash/pipe.scm | 2 +- 3 files changed, 32 insertions(+), 14 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index 8ad33e8..11a6a38 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -209,6 +209,10 @@ the GNU Public License, see COPYING for the copyleft. (define pwd-command (lambda _ (stdout (getcwd)))) +(define (set-command . args) ;; TODO export; env vs set + (define (display-var o) + (format #t "~a=~a\n" (car o) (cdr o))) + (for-each display-var global-variables)) (define %commands ;; Built-in commands. @@ -219,6 +223,7 @@ the GNU Public License, see COPYING for the copyleft. ("jobs" . ,jobs-command) ("bg" . ,bg-command) ("fg" . ,fg-command) + ("set" . ,set-command) ;; Bournish ;; ("echo" ,(lambda strings `(list ,@strings))) @@ -308,12 +313,22 @@ the GNU Public License, see COPYING for the copyleft. (define (sh-exec ast) (define (exec cmd) + (format (current-error-port) "sh-exec:exec cmd=~s\n" cmd) (local-eval cmd (the-environment))) (let ((ast (transform ast))) (match ast ('script #t) ;; skip - (_ (begin (map exec ast) #t))))) - + (_ (let* ((job (map exec ast)) + (stati (append-map (lambda (o) + (cond ((job? o) (job-status o)) + ((boolean? o) (list (if o 0 1))) + (else (list 0)))) ; some commands return a string? + job)) + (status (or (find (negate zero?) stati) 0))) + (set! global-variables (assoc-set! global-variables '$pipe? stati)) + (set! global-variables (assoc-set! global-variables '? status)) + (set! global-variables (assoc-set! global-variables 'fubar status)) + #t))))) (define prompt (let* ((l (string #\001)) diff --git a/gash/job.scm b/gash/job.scm index be3954e..37f30f0 100644 --- a/gash/job.scm +++ b/gash/job.scm @@ -7,16 +7,18 @@ #:use-module (gash io) #:use-module (gash util) - :export (bg - fg - job-add-process - job-control-init - job-debug-id - job-setup-process - jobs-command - new-job - report-jobs - wait)) + #:export (bg + fg + job? + job-add-process + job-control-init + job-debug-id + job-setup-process + job-status + jobs-command + new-job + report-jobs + wait)) (define-record-type (make-process pid command status) @@ -146,7 +148,8 @@ (unless (job-completed? job) (newline) (display-job job)) (reap-jobs) - (or (and (every zero? (job-status job)) 0) 1)) + (or (find (negate zero?) (job-status job)) + 0)) (define (fg index) (let ((job (job-index index))) diff --git a/gash/pipe.scm b/gash/pipe.scm index e669daa..3e42b81 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -15,7 +15,7 @@ #:export (handle-error pipeline pipeline->string substitute)) ;; TODO -(define %debug-level 0) +(define %debug-level 1) (define (handle-error job error) (let ((status (wait job))) From 054db72e94e7ab63a83a3619725ee84651c43c24 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Mon, 2 Jul 2018 19:55:19 +0200 Subject: [PATCH 087/312] WILDE PETS --- gash/gash.scm | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index 11a6a38..69b2fe6 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -165,15 +165,17 @@ the GNU Public License, see COPYING for the copyleft. (cute glob-match (glob2regex pattern) <>)) (or (scandir path) '())))) paths))) - (if (not pattern) '("") - (if (glob? pattern) - (let ((absolute? (string-prefix? "/" pattern))) - (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) - (paths (if absolute? '("/") '(".")))) - (if (null? patterns) - paths - (loop (cdr patterns) (glob- (car patterns) paths))))) - (list pattern)))) + (pk 'pattern: pattern 'glob: + (cond + ((not pattern) '("")) + ((string=? "$?" pattern) (pk 'status: (list (assoc-ref global-variables '?)))) + ((glob? pattern) (let ((absolute? (string-prefix? "/" pattern))) + (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) + (paths (if absolute? '("/") '(".")))) + (if (null? patterns) + paths + (loop (cdr patterns) (glob- (car patterns) paths)))))) + (#t (list pattern))))) (define (background ast) (match ast @@ -194,8 +196,8 @@ the GNU Public License, see COPYING for the copyleft. (define (echo-command . args) (match args (() (newline)) - (("-n" args ...) (display (string-join args))) - (_ (stdout (string-join args))))) + (("-n" args ...) (map display args)) + (_ (map display args) (newline)))) (define (bg-command . args) (match args From 4ef3a941aa0517a9fb957ce4798fdcecd214e5b7 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Mon, 2 Jul 2018 20:05:50 +0200 Subject: [PATCH 088/312] WIP: status:exit-val --- gash/gash.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gash/gash.scm b/gash/gash.scm index 69b2fe6..30ff802 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -326,7 +326,7 @@ the GNU Public License, see COPYING for the copyleft. ((boolean? o) (list (if o 0 1))) (else (list 0)))) ; some commands return a string? job)) - (status (or (find (negate zero?) stati) 0))) + (status (or (find (negate zero?) (map status:exit-val stati)) 0))) (set! global-variables (assoc-set! global-variables '$pipe? stati)) (set! global-variables (assoc-set! global-variables '? status)) (set! global-variables (assoc-set! global-variables 'fubar status)) From 29a54650ab4ee7ba5ace2f36526eddfd50294f35 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Mon, 2 Jul 2018 20:18:59 +0200 Subject: [PATCH 089/312] non builtin hax0r --- gash/pipe.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/gash/pipe.scm b/gash/pipe.scm index 3e42b81..00b256e 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -33,9 +33,10 @@ ;; w[2] -> r[3] [sink] (define (exec* command) ;; list of strings - (catch #t (lambda () (apply execlp (cons (car command) command))) - (lambda (key . args) (format (current-error-port) "~a\n" (caaddr args)) - (exit #f)))) + (let ((command (map (compose with-output-to-string (lambda (c) (lambda () (display c)))) command))) + (catch #t (lambda () (apply execlp (cons (car command) command))) + (lambda (key . args) (format (current-error-port) "~a\n" (caaddr args)) + (exit #f))))) (define ((tee-n file-names) inputs outputs) (let* ((files (map open-output-file file-names)) From 867d83bb69e96cd4999e14ea1add02cd9ce7a221 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 2 Jul 2018 20:20:54 +0200 Subject: [PATCH 090/312] gash -c COMMAND: exit status fix0r --- gash/gash.scm | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index 30ff802..6e1db00 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -49,11 +49,12 @@ (define (display-help) (display "\ gash [options] - -d, --debug Enable PEG tracing - -h, --help Display this help - -p, --parse Parse the shell script and print the parse tree - --prefer-builtins Use builtins, even if command is available in PATH - -v, --version Display the version + -c, --command=STRING Evaluate STRING and exit + -d, --debug Enable PEG tracing + -h, --help Display this help + -p, --parse Parse the shell script and print the parse tree + --prefer-builtins Use builtins, even if command is available in PATH + -v, --version Display the version ")) (define (display-version) @@ -105,7 +106,8 @@ the GNU Public License, see COPYING for the copyleft. (help? (display-help)) (version? (display-version)) (command? (let ((ast (string-to-ast command?))) - (when ast (run ast)))) + (exit (if ast (run ast) + 0)))) ((pair? files) (let* ((asts (map file-to-ast files)) (status (map run asts))) @@ -330,7 +332,7 @@ the GNU Public License, see COPYING for the copyleft. (set! global-variables (assoc-set! global-variables '$pipe? stati)) (set! global-variables (assoc-set! global-variables '? status)) (set! global-variables (assoc-set! global-variables 'fubar status)) - #t))))) + status))))) (define prompt (let* ((l (string #\001)) From b01c5da8acdf057719920299275e058089c733aa Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 3 Jul 2018 19:59:52 +0200 Subject: [PATCH 091/312] Revert "non builtin hax0r" This reverts commit 29a54650ab4ee7ba5ace2f36526eddfd50294f35. --- gash/pipe.scm | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/gash/pipe.scm b/gash/pipe.scm index 00b256e..3e42b81 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -33,10 +33,9 @@ ;; w[2] -> r[3] [sink] (define (exec* command) ;; list of strings - (let ((command (map (compose with-output-to-string (lambda (c) (lambda () (display c)))) command))) - (catch #t (lambda () (apply execlp (cons (car command) command))) - (lambda (key . args) (format (current-error-port) "~a\n" (caaddr args)) - (exit #f))))) + (catch #t (lambda () (apply execlp (cons (car command) command))) + (lambda (key . args) (format (current-error-port) "~a\n" (caaddr args)) + (exit #f)))) (define ((tee-n file-names) inputs outputs) (let* ((files (map open-output-file file-names)) From 567170d226e6cd9dbd06e76873dd5a3a0e25f956 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 3 Jul 2018 20:08:44 +0200 Subject: [PATCH 092/312] variables: use string for key, value. --- gash/gash.scm | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index 6e1db00..ee84309 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -170,7 +170,7 @@ the GNU Public License, see COPYING for the copyleft. (pk 'pattern: pattern 'glob: (cond ((not pattern) '("")) - ((string=? "$?" pattern) (pk 'status: (list (assoc-ref global-variables '?)))) + ((string=? "$?" pattern) (list (assoc-ref global-variables "?"))) ((glob? pattern) (let ((absolute? (string-prefix? "/" pattern))) (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) (paths (if absolute? '("/") '(".")))) @@ -328,10 +328,19 @@ the GNU Public License, see COPYING for the copyleft. ((boolean? o) (list (if o 0 1))) (else (list 0)))) ; some commands return a string? job)) - (status (or (find (negate zero?) (map status:exit-val stati)) 0))) - (set! global-variables (assoc-set! global-variables '$pipe? stati)) - (set! global-variables (assoc-set! global-variables '? status)) - (set! global-variables (assoc-set! global-variables 'fubar status)) + (stati (map status:exit-val stati)) + (status (or (find (negate zero?) stati) 0)) + ;; mimick BASH for now + (pipestatus (string-append + "(" + (string-join + (map (lambda (s i) + (format #f "[~a]=\"~a\"" s i)) + stati + (iota (length stati)))) + ")"))) + (set! global-variables (assoc-set! global-variables "PIPESTATUS" pipestatus)) + (set! global-variables (assoc-set! global-variables "?" (number->string status))) status))))) (define prompt From c4ea4457f950945dcb590e04065ce1fa1c415d24 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 3 Jul 2018 20:38:30 +0200 Subject: [PATCH 093/312] implement set -e. --- gash/gash.scm | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index ee84309..b2e26cc 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -68,7 +68,7 @@ the GNU Public License, see COPYING for the copyleft. ")) -(define global-variables '()) +(define global-variables (list '("SHELLOPTS" . ""))) (define (main args) (map (lambda (key-value) @@ -216,7 +216,24 @@ the GNU Public License, see COPYING for the copyleft. (define (set-command . args) ;; TODO export; env vs set (define (display-var o) (format #t "~a=~a\n" (car o) (cdr o))) - (for-each display-var global-variables)) + (match args + (() (for-each display-var global-variables)) + (("-e") (set-shell-opt "errexit" #t)) + (("+e") (set-shell-opt "errexit" #f)) + (("-x") (set-shell-opt "xtrace" #t)) + (("+x") (set-shell-opt "xtrace" #f)))) + +(define (set-shell-opt name set?) + (let* ((shell-opts (assoc-ref global-variables "SHELLOPTS")) + (options (if (string-null? shell-opts) '() + (string-split shell-opts #\:))) + (new-options (if set? (delete-duplicates (sort (cons name options) string<)) + (filter (negate (cut equal? <> name)) options))) + (new-shell-opts (string-join new-options ":"))) + (set! global-variables (assoc-set! global-variables "SHELLOPTS" new-shell-opts)))) + +(define (shell-opt? name) + (member name (string-split (assoc-ref global-variables "SHELLOPTS") #\:))) (define %commands ;; Built-in commands. @@ -341,6 +358,9 @@ the GNU Public License, see COPYING for the copyleft. ")"))) (set! global-variables (assoc-set! global-variables "PIPESTATUS" pipestatus)) (set! global-variables (assoc-set! global-variables "?" (number->string status))) + (when (and (not (zero? status)) + (shell-opt? "errexit")) + (exit status)) status))))) (define prompt From f047fd2d2a3920f043487041814ab2a0c8974710 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 3 Jul 2018 20:40:47 +0200 Subject: [PATCH 094/312] exit: new builtin. --- gash/gash.scm | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/gash/gash.scm b/gash/gash.scm index b2e26cc..7454f17 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -223,6 +223,14 @@ the GNU Public License, see COPYING for the copyleft. (("-x") (set-shell-opt "xtrace" #t)) (("+x") (set-shell-opt "xtrace" #f)))) +(define (exit-command . args) + (match args + (() (exit 0)) + ((status) + (exit (string->number status))) + ((args ...) + (format (current-error-port) "exit: too many arguments: ~a\n" (string-join args))))) + (define (set-shell-opt name set?) (let* ((shell-opts (assoc-ref global-variables "SHELLOPTS")) (options (if (string-null? shell-opts) '() @@ -245,6 +253,7 @@ the GNU Public License, see COPYING for the copyleft. ("bg" . ,bg-command) ("fg" . ,fg-command) ("set" . ,set-command) + ("exit" . ,exit-command) ;; Bournish ;; ("echo" ,(lambda strings `(list ,@strings))) From cda9eda403763c43b7550c52eb7ee172bc6e2ea3 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 3 Jul 2018 20:55:14 +0200 Subject: [PATCH 095/312] implement set -x. --- gash/gash.scm | 3 ++- gash/pipe.scm | 6 ++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/gash/gash.scm b/gash/gash.scm index 7454f17..542dd08 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -19,7 +19,8 @@ #:use-module (gash io) #:use-module (gash util) - #:export (main)) + #:export (main + shell-opt?)) (define (remove-shell-comments s) (string-join (map diff --git a/gash/pipe.scm b/gash/pipe.scm index 3e42b81..b531958 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -9,6 +9,7 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) + #:use-module (gash gash) #:use-module (gash job) #:use-module (gash io) @@ -90,6 +91,11 @@ (define (pipeline fg? . commands) (when (> %debug-level 0) (format (current-error-port) "pipeline[~a]: COMMANDS: ~s\n" fg? commands)) + (when (shell-opt? "xtrace") + (for-each + (lambda (o) + (format (current-error-port) "+ ~a\n" (string-join o))) + (reverse commands))) (receive (r w) (pipe*) (move->fdes w 2) From 61ee206b8dcb8bdea77799f8354aa53decb4702c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 3 Jul 2018 20:56:49 +0200 Subject: [PATCH 096/312] softcode --debug levels. --- gash/gash.scm | 34 +++++++++++++++++++++------------- gash/pipe.scm | 3 --- 2 files changed, 21 insertions(+), 16 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index 542dd08..6f358bc 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -20,8 +20,11 @@ #:use-module (gash util) #:export (main + %debug-level shell-opt?)) +(define %debug-level 0) + (define (remove-shell-comments s) (string-join (map (lambda (s) @@ -89,6 +92,8 @@ the GNU Public License, see COPYING for the copyleft. (version (single-char #\v) (value #f)))) (options (getopt-long args option-spec #:stop-at-first-non-option #t )) (command? (option-ref options 'command #f)) + (opt? (lambda (name) (lambda (o) (and (eq? (car o) name) (cdr o))))) + (debug (length (filter-map (opt? 'debug) options))) (help? (option-ref options 'help #f)) (parse? (option-ref options 'parse #f)) (version? (option-ref options 'version #f)) @@ -103,6 +108,8 @@ the GNU Public License, see COPYING for the copyleft. (#t (sh-exec ast)))))) (set! %prefer-builtins? (option-ref options 'prefer-builtins #f)) + (if (option-ref options 'debug #f) + (set! %debug-level debug)) (cond (help? (display-help)) (version? (display-version)) @@ -168,17 +175,16 @@ the GNU Public License, see COPYING for the copyleft. (cute glob-match (glob2regex pattern) <>)) (or (scandir path) '())))) paths))) - (pk 'pattern: pattern 'glob: - (cond - ((not pattern) '("")) - ((string=? "$?" pattern) (list (assoc-ref global-variables "?"))) - ((glob? pattern) (let ((absolute? (string-prefix? "/" pattern))) - (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) - (paths (if absolute? '("/") '(".")))) - (if (null? patterns) - paths - (loop (cdr patterns) (glob- (car patterns) paths)))))) - (#t (list pattern))))) + (cond + ((not pattern) '("")) + ((string=? "$?" pattern) (list (assoc-ref global-variables "?"))) + ((glob? pattern) (let ((absolute? (string-prefix? "/" pattern))) + (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) + (paths (if absolute? '("/") '(".")))) + (if (null? patterns) + paths + (loop (cdr patterns) (glob- (car patterns) paths)))))) + (#t (list pattern)))) (define (background ast) (match ast @@ -279,7 +285,8 @@ the GNU Public License, see COPYING for the copyleft. ((('glob command)) (values command #f)) (_ (values #f #f))) (let ((program (and command (PATH-search-path command)))) - (format (current-error-port) "command ~a => ~s ~s\n" program command args) + (when (> %debug-level 0) + (format (current-error-port) "command ~a => ~s ~s\n" program command args)) (cond ((and program (not %prefer-builtins?)) #f) ((and command (assoc-ref %commands command)) @@ -344,7 +351,8 @@ the GNU Public License, see COPYING for the copyleft. (define (sh-exec ast) (define (exec cmd) - (format (current-error-port) "sh-exec:exec cmd=~s\n" cmd) + (when (> %debug-level 0) + (format (current-error-port) "sh-exec:exec cmd=~s\n" cmd)) (local-eval cmd (the-environment))) (let ((ast (transform ast))) (match ast diff --git a/gash/pipe.scm b/gash/pipe.scm index b531958..5f18b88 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -15,9 +15,6 @@ #:export (handle-error pipeline pipeline->string substitute)) -;; TODO -(define %debug-level 1) - (define (handle-error job error) (let ((status (wait job))) (when (not (zero? status)) From 503be95f973e34d1643ecad5edb9cce15a10cdc7 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 3 Jul 2018 21:49:55 +0200 Subject: [PATCH 097/312] test: Updates. --- configure | 2 ++ makefile | 16 +++++++++++++--- test.sh | 18 +++++++++++++++++- test/00-exit.sh | 1 + test/01-exit-0.sh | 1 + test/02-exit-1.exit | 1 + test/02-exit-1.sh | 1 + test/03-echo.sh | 1 + test/04-echo-var.sh | 1 + test/{assignment => 05-assignment.sh} | 0 test/06-assignment-echo.sh | 2 ++ test/{find => find.sh} | 0 test/for | 1 - test/for.sh | 1 + test/{ifthen => ifthen.sh} | 0 test/{ifthenelse => ifthenelse.sh} | 0 test/{iohere => iohere.sh} | 0 test/{list => list.sh} | 0 test/{ls => ls.sh} | 0 test/{nesting => nesting.sh} | 0 test/{pipe => pipe.sh} | 0 test/{substitution => substitution.sh} | 0 test/{test => test.sh} | 0 test/var | 1 - 24 files changed, 41 insertions(+), 6 deletions(-) create mode 100644 test/00-exit.sh create mode 100644 test/01-exit-0.sh create mode 100644 test/02-exit-1.exit create mode 100644 test/02-exit-1.sh create mode 100644 test/03-echo.sh create mode 100644 test/04-echo-var.sh rename test/{assignment => 05-assignment.sh} (100%) create mode 100644 test/06-assignment-echo.sh rename test/{find => find.sh} (100%) delete mode 100644 test/for create mode 100644 test/for.sh rename test/{ifthen => ifthen.sh} (100%) rename test/{ifthenelse => ifthenelse.sh} (100%) rename test/{iohere => iohere.sh} (100%) rename test/{list => list.sh} (100%) rename test/{ls => ls.sh} (100%) rename test/{nesting => nesting.sh} (100%) rename test/{pipe => pipe.sh} (100%) rename test/{substitution => substitution.sh} (100%) rename test/{test => test.sh} (100%) delete mode 100644 test/var diff --git a/configure b/configure index 5c038d6..bced961 100755 --- a/configure +++ b/configure @@ -9,6 +9,7 @@ if [ -z "$PREFIX" ]; then PREFIX=/usr/local fi +BASH=$(command -v bash) GUILE=$(command -v guile) GUILE_TOOLS=$(command -v guile-tools) GUILE_SITE_DIR=$PREFIX/share/guile/site/$GUILE_EFFECTIVE_VERSION @@ -22,6 +23,7 @@ sed \ bin/gash.in > bin/gash chmod +x bin/gash cat > .config.make < Date: Wed, 4 Jul 2018 06:58:01 +0200 Subject: [PATCH 098/312] Add -e, -x options. Use -x for running tests. --- gash/gash.scm | 30 ++++++++++++++++++------------ test.sh | 2 +- test/20-pipe-exit-0.sh | 1 + test/21-pipe-exit-1.exit | 1 + test/21-pipe-exit-1.sh | 1 + todo/22-semi-pipe-exit-0.sh | 2 ++ 6 files changed, 24 insertions(+), 13 deletions(-) create mode 100644 test/20-pipe-exit-0.sh create mode 100644 test/21-pipe-exit-1.exit create mode 100644 test/21-pipe-exit-1.sh create mode 100644 todo/22-semi-pipe-exit-0.sh diff --git a/gash/gash.scm b/gash/gash.scm index 6f358bc..b3cdb8a 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -54,11 +54,13 @@ (display "\ gash [options] -c, --command=STRING Evaluate STRING and exit + -e, --errexit Exit upon error -d, --debug Enable PEG tracing -h, --help Display this help -p, --parse Parse the shell script and print the parse tree --prefer-builtins Use builtins, even if command is available in PATH -v, --version Display the version + -x, --xtrace Print simple command trace ")) (define (display-version) @@ -72,7 +74,7 @@ the GNU Public License, see COPYING for the copyleft. ")) -(define global-variables (list '("SHELLOPTS" . ""))) +(define global-variables (list (cons "SHELLOPTS" ""))) (define (main args) (map (lambda (key-value) @@ -85,11 +87,13 @@ the GNU Public License, see COPYING for the copyleft. (lambda () (job-control-init) (let* ((option-spec '((command (single-char #\c) (value #t)) - (debug (single-char #\d) (value #f)) - (help (single-char #\h) (value #f)) - (parse (single-char #\p) (value #f)) + (debug (single-char #\d)) + (errexit (single-char #\e)) + (help (single-char #\h)) + (parse (single-char #\p)) (prefer-builtins) - (version (single-char #\v) (value #f)))) + (version (single-char #\v)) + (xtrace (single-char #\x)))) (options (getopt-long args option-spec #:stop-at-first-non-option #t )) (command? (option-ref options 'command #f)) (opt? (lambda (name) (lambda (o) (and (eq? (car o) name) (cdr o))))) @@ -108,6 +112,8 @@ the GNU Public License, see COPYING for the copyleft. (#t (sh-exec ast)))))) (set! %prefer-builtins? (option-ref options 'prefer-builtins #f)) + (set-shell-opt! "errexit" (option-ref options 'errexit #f)) + (set-shell-opt! "xtrace" (option-ref options 'xtrace #f)) (if (option-ref options 'debug #f) (set! %debug-level debug)) (cond @@ -225,10 +231,10 @@ the GNU Public License, see COPYING for the copyleft. (format #t "~a=~a\n" (car o) (cdr o))) (match args (() (for-each display-var global-variables)) - (("-e") (set-shell-opt "errexit" #t)) - (("+e") (set-shell-opt "errexit" #f)) - (("-x") (set-shell-opt "xtrace" #t)) - (("+x") (set-shell-opt "xtrace" #f)))) + (("-e") (set-shell-opt! "errexit" #t)) + (("+e") (set-shell-opt! "errexit" #f)) + (("-x") (set-shell-opt! "xtrace" #t)) + (("+x") (set-shell-opt! "xtrace" #f)))) (define (exit-command . args) (match args @@ -238,7 +244,7 @@ the GNU Public License, see COPYING for the copyleft. ((args ...) (format (current-error-port) "exit: too many arguments: ~a\n" (string-join args))))) -(define (set-shell-opt name set?) +(define (set-shell-opt! name set?) (let* ((shell-opts (assoc-ref global-variables "SHELLOPTS")) (options (if (string-null? shell-opts) '() (string-split shell-opts #\:))) @@ -364,8 +370,8 @@ the GNU Public License, see COPYING for the copyleft. (else (list 0)))) ; some commands return a string? job)) (stati (map status:exit-val stati)) - (status (or (find (negate zero?) stati) 0)) - ;; mimick BASH for now + (status (if (shell-opt? "pipefail") (or (find (negate zero?) (reverse stati)) 0) + (last stati))) (pipestatus (string-append "(" (string-join diff --git a/test.sh b/test.sh index 427abb0..92f269c 100755 --- a/test.sh +++ b/test.sh @@ -5,7 +5,7 @@ SHELL=${SHELL-bin/gash} for f in test/*.sh; do echo -n "$f: " b=test/$(basename $f .sh) - $SHELL $f + $SHELL -e $f r=$? if [ -f $b.exit ]; then e=$(cat $b.exit) diff --git a/test/20-pipe-exit-0.sh b/test/20-pipe-exit-0.sh new file mode 100644 index 0000000..d09faab --- /dev/null +++ b/test/20-pipe-exit-0.sh @@ -0,0 +1 @@ +false | true diff --git a/test/21-pipe-exit-1.exit b/test/21-pipe-exit-1.exit new file mode 100644 index 0000000..56a6051 --- /dev/null +++ b/test/21-pipe-exit-1.exit @@ -0,0 +1 @@ +1 \ No newline at end of file diff --git a/test/21-pipe-exit-1.sh b/test/21-pipe-exit-1.sh new file mode 100644 index 0000000..8bfc37e --- /dev/null +++ b/test/21-pipe-exit-1.sh @@ -0,0 +1 @@ +true | false diff --git a/todo/22-semi-pipe-exit-0.sh b/todo/22-semi-pipe-exit-0.sh new file mode 100644 index 0000000..67bf325 --- /dev/null +++ b/todo/22-semi-pipe-exit-0.sh @@ -0,0 +1,2 @@ +# gash makes this into a pipeline, then uses `true''s exit status +false ; true From 0bc6de34d1c7afe62f5f438981c70dcf7cc461b9 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 4 Jul 2018 19:17:52 +0200 Subject: [PATCH 099/312] bugfix: test/22-semi-pipe-exit-0.sh --- gash/gash.scm | 45 +++++++++++++-------------- test/22-semi-pipe-exit-0.exit | 1 + {todo => test}/22-semi-pipe-exit-0.sh | 0 3 files changed, 22 insertions(+), 24 deletions(-) create mode 100644 test/22-semi-pipe-exit-0.exit rename {todo => test}/22-semi-pipe-exit-0.sh (100%) diff --git a/gash/gash.scm b/gash/gash.scm index b3cdb8a..d4feee8 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -359,33 +359,30 @@ the GNU Public License, see COPYING for the copyleft. (define (exec cmd) (when (> %debug-level 0) (format (current-error-port) "sh-exec:exec cmd=~s\n" cmd)) - (local-eval cmd (the-environment))) + (let* ((job (local-eval cmd (the-environment))) + (stati (cond ((job? job) (job-status job)) + ((boolean? job) (list (if job 0 1))) + (else (list 0)))) + (stati (map status:exit-val stati)) + (status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0) + (car stati))) + (pipestatus (string-append + "(" + (string-join + (map (lambda (s i) + (format #f "[~a]=\"~a\"" s i)) + stati + (iota (length stati)))) + ")"))) + (set! global-variables (assoc-set! global-variables "PIPESTATUS" pipestatus)) + (set! global-variables (assoc-set! global-variables "?" (number->string status))) + (when (and (not (zero? status)) + (shell-opt? "errexit")) + (exit status)))) (let ((ast (transform ast))) (match ast ('script #t) ;; skip - (_ (let* ((job (map exec ast)) - (stati (append-map (lambda (o) - (cond ((job? o) (job-status o)) - ((boolean? o) (list (if o 0 1))) - (else (list 0)))) ; some commands return a string? - job)) - (stati (map status:exit-val stati)) - (status (if (shell-opt? "pipefail") (or (find (negate zero?) (reverse stati)) 0) - (last stati))) - (pipestatus (string-append - "(" - (string-join - (map (lambda (s i) - (format #f "[~a]=\"~a\"" s i)) - stati - (iota (length stati)))) - ")"))) - (set! global-variables (assoc-set! global-variables "PIPESTATUS" pipestatus)) - (set! global-variables (assoc-set! global-variables "?" (number->string status))) - (when (and (not (zero? status)) - (shell-opt? "errexit")) - (exit status)) - status))))) + (_ (for-each exec ast))))) (define prompt (let* ((l (string #\001)) diff --git a/test/22-semi-pipe-exit-0.exit b/test/22-semi-pipe-exit-0.exit new file mode 100644 index 0000000..d00491f --- /dev/null +++ b/test/22-semi-pipe-exit-0.exit @@ -0,0 +1 @@ +1 diff --git a/todo/22-semi-pipe-exit-0.sh b/test/22-semi-pipe-exit-0.sh similarity index 100% rename from todo/22-semi-pipe-exit-0.sh rename to test/22-semi-pipe-exit-0.sh From 836f7627b26421a559ecb428ad3fce91e31d1c38 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 4 Jul 2018 20:02:49 +0200 Subject: [PATCH 100/312] Import bournish commands from GNU Guix. * AUTHORS: New file. * gash/bournish-commands.scm: New file. Imported and adapted from GNU Guix. * gash/bournish-commands.scm: Likewise. * gash/gash.scm (%commands): Add commands from Bournish. --- AUTHORS | 10 ++ build-aux/build-guile.sh | 2 + gash/bournish-commands.scm | 218 +++++++++++++++++++++++++++++++++++++ gash/gash.scm | 56 +++++----- gash/guix-build-utils.scm | 67 ++++++++++++ 5 files changed, 328 insertions(+), 25 deletions(-) create mode 100644 AUTHORS create mode 100644 gash/bournish-commands.scm create mode 100644 gash/guix-build-utils.scm diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 0000000..4d3661a --- /dev/null +++ b/AUTHORS @@ -0,0 +1,10 @@ +Rutger EW van Beusekom +Main author +All files except the imported files listed below + +Adapted from GNU Guix +gash/bournish-commands.scm +gash/guix-build-utils.scm + +Adapted from Mes +build-aux/build-guile.sh diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index d499bfc..7c4f75a 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -36,6 +36,8 @@ GUILE_AUTO_COMPILE=0 set -e SCM_FILES=" +gash/bournish-commands.scm +gash/guix-build-utils.scm gash/gash.scm gash/io.scm gash/job.scm diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm new file mode 100644 index 0000000..bdc1518 --- /dev/null +++ b/gash/bournish-commands.scm @@ -0,0 +1,218 @@ +;;; Gash -- Guile As Shell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +(define-module (gash bournish-commands) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (gash guix-build-utils) + #:use-module (gash io) + #:export ( + cat-command + ls-command + reboot-command + rm-command + wc-command + which-command + )) + +;;; Commentary: + +;;; This code is taken from (guix build bournish) + +;;; +;;; This is a super minimal Bourne-like shell language for Guile. It is meant +;;; to be used at the REPL as a rescue shell. In a way, this is to Guile what +;;; eshell is to Emacs. +;;; +;;; Code: + +(define (expand-variable str) + "Return STR or code to obtain the value of the environment variable STR +refers to." + ;; XXX: No support for "${VAR}". + (if (string-prefix? "$" str) + `(or (getenv ,(string-drop str 1)) "") + str)) + +(define* (display-tabulated lst + #:key + (terminal-width 80) + (column-gap 2)) + "Display the list of string LST in as many columns as needed given +TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." + (define len (length lst)) + (define column-width + ;; The width of a column. Assume all the columns have the same width + ;; (GNU ls is smarter than that.) + (+ column-gap (reduce max 0 (map string-length lst)))) + (define columns + (max 1 + (quotient terminal-width column-width))) + (define pad + (if (zero? (modulo len columns)) + 0 + columns)) + (define items-per-column + (quotient (+ len pad) columns)) + (define items (list->vector lst)) + + (let loop ((indexes (unfold (cut >= <> columns) + (cut * <> items-per-column) + 1+ + 0))) + (unless (>= (first indexes) items-per-column) + (for-each (lambda (index) + (let ((item (if (< index len) + (vector-ref items index) + ""))) + (display (string-pad-right item column-width)))) + indexes) + (newline) + (loop (map 1+ indexes))))) + +(define ls-command-implementation + ;; Run-time support procedure. + (case-lambda + (() + (display-tabulated (scandir "."))) + (files + (let ((files (append-map (lambda (file) + (catch 'system-error + (lambda () + (match (stat:type (lstat file)) + ('directory + ;; Like GNU ls, list the contents of + ;; FILE rather than FILE itself. + (match (scandir file + (match-lambda + ((or "." "..") #f) + (_ #t))) + (#f + (list file)) + ((files ...) + (map (cut string-append file "/" <>) + files)))) + (_ + (list file)))) + (lambda args + (let ((errno (system-error-errno args))) + (format (current-error-port) "~a: ~a~%" + file (strerror errno)) + '())))) + files))) + (display-tabulated files))))) + +(define (ls-command . files) + (apply ls-command-implementation files)) + +(define (which-command program . rest) + (stdout (search-path (executable-path) program))) + +(define (cat-command file . rest) + (call-with-input-file file + (lambda (port) + (dump-port port (current-output-port)) + *unspecified*))) + +(define (rm-command . args) + "Emit code for the 'rm' command." + (cond ((member "-r" args) + (for-each delete-file-recursively + (apply delete (cons "-r" args)))) + (else + (for-each delete-file args)))) + +(define (lines+chars port) + "Return the number of lines and number of chars read from PORT." + (let loop ((lines 0) (chars 0)) + (match (read-char port) + ((? eof-object?) ;done! + (values lines chars)) + (#\newline ;recurse + (loop (1+ lines) (1+ chars))) + (_ ;recurse + (loop lines (1+ chars)))))) + +(define (file-exists?* file) + "Like 'file-exists?' but emits a warning if FILE is not accessible." + (catch 'system-error + (lambda () + (stat file)) + (lambda args + (let ((errno (system-error-errno args))) + (format (current-error-port) "~a: ~a~%" + file (strerror errno)) + #f)))) + +(define (wc-print file) + (let-values (((lines chars) + (call-with-input-file file lines+chars))) + (format #t "~a ~a ~a~%" lines chars file))) + +(define (wc-l-print file) + (let-values (((lines chars) + (call-with-input-file file lines+chars))) + (format #t "~a ~a~%" lines file))) + +(define (wc-c-print file) + (let-values (((lines chars) + (call-with-input-file file lines+chars))) + (format #t "~a ~a~%" chars file))) + +(define (wc-command-implementation . files) + (for-each wc-print (filter file-exists?* files))) + +(define (wc-l-command-implementation . files) + (for-each wc-l-print (filter file-exists?* files))) + +(define (wc-c-command-implementation . files) + (for-each wc-c-print (filter file-exists?* files))) + +(define (wc-command . args) + "Emit code for the 'wc' command." + (cond ((member "-l" args) + (apply wc-l-command-implementation (delete "-l" args))) + ((member "-c" args) + (apply wc-c-command-implementation (delete "-c" args))) + (else + (apply wc-command-implementation args)))) + +(define (reboot-command . args) + "Emit code for 'reboot'." + ;; Normally Bournish is used in the initrd, where 'reboot' is provided + ;; directly by (guile-user). In other cases, just bail out. + (if (defined? 'reboot) + (reboot) + (begin + (format (current-error-port) + "I don't know how to reboot, sorry about that!~%") + 1))) + +(define %not-colon (char-set-complement (char-set #\:))) +(define (executable-path) + "Return the search path for programs as a list." + (match (getenv "PATH") + (#f '()) + (str (string-tokenize str %not-colon)))) diff --git a/gash/gash.scm b/gash/gash.scm index d4feee8..198c002 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -18,6 +18,7 @@ #:use-module (gash peg) #:use-module (gash io) #:use-module (gash util) + #:use-module (gash bournish-commands) #:export (main %debug-level @@ -67,10 +68,11 @@ gash [options] (display " GASH 0.1 -Copryright (C) 2016 R.E.W. van Beusekom, rutger.van.beusekom@gmail.com. +Copryright (C) 2016,2017,2018 R.E.W. van Beusekom, rutger.van.beusekom@gmail.com. -This is gash, Guile As SHell. Gash is free software and is covered by -the GNU Public License, see COPYING for the copyleft. +This is gash, Guile As SHell. Gash is free software and is covered by +the GNU General Public License version 3 or later, see COPYING for the +copyleft. ")) @@ -244,6 +246,16 @@ the GNU Public License, see COPYING for the copyleft. ((args ...) (format (current-error-port) "exit: too many arguments: ~a\n" (string-join args))))) +(define (help-command . _) + (display "\ +Hello, this is gash, Guile As SHell. + +TODO +")) + +(define (cp-command source dest) + `(copy-file ,source ,dest)) + (define (set-shell-opt! name set?) (let* ((shell-opts (assoc-ref global-variables "SHELLOPTS")) (options (if (string-null? shell-opts) '() @@ -259,28 +271,22 @@ the GNU Public License, see COPYING for the copyleft. (define %commands ;; Built-in commands. `( - ("echo" . ,echo-command) - ("cd" . ,cd-command) - ("pwd" . ,pwd-command) - ("jobs" . ,jobs-command) - ("bg" . ,bg-command) - ("fg" . ,fg-command) - ("set" . ,set-command) - ("exit" . ,exit-command) - - ;; Bournish - ;; ("echo" ,(lambda strings `(list ,@strings))) - ;; ("cd" ,(lambda (dir) `(chdir ,dir))) - ;; ("pwd" ,(lambda () `(getcwd))) - ;; ("rm" ,rm-command) - ;; ("cp" ,(lambda (source dest) `(copy-file ,source ,dest))) - ;; ("help" ,help-command) - ;; ("ls" ,ls-command) - ;; ("which" ,which-command) - ;; ("cat" ,cat-command) - ;; ("wc" ,wc-command) - ;; ("reboot" ,reboot-command) - + ("bg" . ,bg-command) + ("cat" . ,cat-command) + ("cd" . ,cd-command) + ("cp" . ,cp-command) + ("echo" . ,echo-command) + ("exit" . ,exit-command) + ("fg" . ,fg-command) + ("help" . ,help-command) + ("jobs" . ,jobs-command) + ("ls" . ,ls-command) + ("pwd" . ,pwd-command) + ("reboot" . ,reboot-command) + ("rm" . ,rm-command) + ("set" . ,set-command) + ("wc" . ,wc-command) + ("which" . ,which-command) )) (define %prefer-builtins? #t) ; use builtin, even if COMMAND is available in PATH? diff --git a/gash/guix-build-utils.scm b/gash/guix-build-utils.scm new file mode 100644 index 0000000..896cc6d --- /dev/null +++ b/gash/guix-build-utils.scm @@ -0,0 +1,67 @@ +;;; Gash -- Guile As Shell +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013 Nikita Karetnikov +;;; Copyright © 2015, 2018 Mark H Weaver +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + + +(define-module (gash guix-build-utils) + ;; #:use-module (srfi srfi-1) + ;; #:use-module (srfi srfi-11) + ;; #:use-module (srfi srfi-26) + ;; #:use-module (srfi srfi-34) + ;; #:use-module (srfi srfi-35) + ;; #:use-module (srfi srfi-60) + ;; #:use-module (ice-9 ftw) + ;; #:use-module (ice-9 match) + ;; #:use-module (ice-9 regex) + ;; #:use-module (ice-9 rdelim) + ;; #:use-module (ice-9 format) + ;; #:use-module (ice-9 threads) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:export (dump-port)) + +;;; Commentary: + +;;; This code is taken from (guix build utils) + +(define* (dump-port in out + #:key (buffer-size 16384) + (progress (lambda (t k) (k)))) + "Read as much data as possible from IN and write it to OUT, using chunks of +BUFFER-SIZE bytes. Call PROGRESS at the beginning and after each successful +transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes +transferred and the continuation of the transfer as a thunk." + (define buffer + (make-bytevector buffer-size)) + + (define (loop total bytes) + (or (eof-object? bytes) + (let ((total (+ total bytes))) + (put-bytevector out buffer 0 bytes) + (progress total + (lambda () + (loop total + (get-bytevector-n! in buffer 0 buffer-size))))))) + + ;; Make sure PROGRESS is called when we start so that it can measure + ;; throughput. + (progress 0 + (lambda () + (loop 0 (get-bytevector-n! in buffer 0 buffer-size))))) From b5632a010375a3f2a863a21d9deb25c3397072d7 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 4 Jul 2018 20:10:06 +0200 Subject: [PATCH 101/312] remove BUGS --- BUGS | 13 ------------- todo/process-substitution-in | 1 + 2 files changed, 1 insertion(+), 13 deletions(-) delete mode 100644 BUGS create mode 100644 todo/process-substitution-in diff --git a/BUGS b/BUGS deleted file mode 100644 index 87b2c29..0000000 --- a/BUGS +++ /dev/null @@ -1,13 +0,0 @@ - -*- org -*- -* TODO -** bin/gash --debug --parse <(echo done) -** bin/gash <(echo 'echo "$foo"') -prints: $bar -** bin/gash <(echo 'echo "foo=$bar"') -prints: foo=$bar -** bin/gash <(echo 'echo "foo:$bar"') -prints: foo:$bar - -* DONE -** bin/gash --debug --parse <(echo 'foo=`eval echo $bar`') -** gash -c STRING diff --git a/todo/process-substitution-in b/todo/process-substitution-in new file mode 100644 index 0000000..b22ae6f --- /dev/null +++ b/todo/process-substitution-in @@ -0,0 +1 @@ +cat <(cat README) \ No newline at end of file From 41f723c4170be1b7329b2676d434937854b53bde Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 4 Jul 2018 20:11:26 +0200 Subject: [PATCH 102/312] Geiser support. * .dir-locals.el: Geiser support. --- .dir-locals.el | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 .dir-locals.el diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..eee7813 --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,13 @@ +((nil + . + ((indent-tabs-mode . nil))) + (makefile-mode + (indent-tabs-mode . t)) + (scheme-mode + . + ((geiser-active-implementations . (guile)) + (eval + . + (progn + (let ((top (locate-dominating-file default-directory ".dir-locals.el"))) + (add-to-list 'geiser-guile-load-path top))))))) From f5ee21eb36ab52f8d9c3bf911843607f5a00d868 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 4 Jul 2018 20:35:28 +0200 Subject: [PATCH 103/312] Update help and root prompt. --- gash/bournish-commands.scm | 1 + gash/gash.scm | 10 +++++++--- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index bdc1518..ef03457 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -29,6 +29,7 @@ #:use-module (gash guix-build-utils) #:use-module (gash io) #:export ( + display-tabulated cat-command ls-command reboot-command diff --git a/gash/gash.scm b/gash/gash.scm index 198c002..1ecdcbc 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -250,8 +250,12 @@ copyleft. (display "\ Hello, this is gash, Guile As SHell. -TODO -")) +Gash is work in progress; many language constructs work, pipes work, +some redirections work. +") + (when (or %prefer-builtins? (not (PATH-search-path "ls"))) + (display "\nIt features the following, somewhat naive builtin commands\n") + (display-tabulated (map car %commands)))) (define (cp-command source dest) `(copy-file ,source ,dest)) @@ -405,7 +409,7 @@ TODO (report-jobs) (string-append l e "[01;32m" r user "@" host l e "[00m" r ":" - l e "[01;34m" r cwd l e "[00m" r "$ "))))) + l e "[01;34m" r cwd l e "[00m" r (if (zero? (getuid)) "# " "$ ")))))) (define (string-prefix s1 s2) (substring/read-only s1 0 (string-prefix-length s1 s2))) From d920fe1b4a2ef4ae957663323e2a50fd753abb6b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 4 Jul 2018 20:36:58 +0200 Subject: [PATCH 104/312] oops: bugfix `cp' FIXUP: bournish commit. --- gash/gash.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index 1ecdcbc..8da950e 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -257,8 +257,8 @@ some redirections work. (display "\nIt features the following, somewhat naive builtin commands\n") (display-tabulated (map car %commands)))) -(define (cp-command source dest) - `(copy-file ,source ,dest)) +(define (cp-command source dest . rest) + (copy-file source dest)) (define (set-shell-opt! name set?) (let* ((shell-opts (assoc-ref global-variables "SHELLOPTS")) From 8c441105fe8a347337e5d44294ca118ff5dcfd87 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 4 Jul 2018 21:03:56 +0200 Subject: [PATCH 105/312] bournish: cp, rm: handle exit stati. --- gash/bournish-commands.scm | 15 ++++++++++----- gash/gash.scm | 12 +++++++++--- 2 files changed, 19 insertions(+), 8 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index ef03457..b87bdb0 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -139,11 +139,16 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." (define (rm-command . args) "Emit code for the 'rm' command." - (cond ((member "-r" args) - (for-each delete-file-recursively - (apply delete (cons "-r" args)))) - (else - (for-each delete-file args)))) + (catch #t + (lambda _ + (cond ((member "-r" args) + (for-each delete-file-recursively + (apply delete (cons "-r" args)))) + (else + (for-each delete-file args)))) + (lambda (key . args) + (format (current-error-port) "rm: ~a ~a\n" key args) + 1))) (define (lines+chars port) "Return the number of lines and number of chars read from PORT." diff --git a/gash/gash.scm b/gash/gash.scm index 8da950e..3f23b4a 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -258,7 +258,13 @@ some redirections work. (display-tabulated (map car %commands)))) (define (cp-command source dest . rest) - (copy-file source dest)) + (catch #t + (lambda _ + (copy-file source dest) + 0) + (lambda (key . args) + (format (current-error-port) "cp: ~a ~a\n" key args) + 1))) (define (set-shell-opt! name set?) (let* ((shell-opts (assoc-ref global-variables "SHELLOPTS")) @@ -370,10 +376,10 @@ some redirections work. (when (> %debug-level 0) (format (current-error-port) "sh-exec:exec cmd=~s\n" cmd)) (let* ((job (local-eval cmd (the-environment))) - (stati (cond ((job? job) (job-status job)) + (stati (cond ((job? job) (map status:exit-val (job-status job))) ((boolean? job) (list (if job 0 1))) + ((number? job) (list job)) (else (list 0)))) - (stati (map status:exit-val stati)) (status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0) (car stati))) (pipestatus (string-append From b8e41cfa551ec82b19e11b2e31c7e1cc7f831111 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 4 Jul 2018 21:11:27 +0200 Subject: [PATCH 106/312] typos --- gash/bournish-commands.scm | 2 +- gash/gash.scm | 4 ++-- gash/guix-build-utils.scm | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index b87bdb0..1c1ae52 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As Shell +;;; Gash -- Guile As SHell ;;; Copyright © 2016, 2017 Ludovic Courtès ;;; Copyright © 2016 Efraim Flashner ;;; Copyright © 2017 Ricardo Wurmus diff --git a/gash/gash.scm b/gash/gash.scm index 3f23b4a..08fb694 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -250,8 +250,8 @@ copyleft. (display "\ Hello, this is gash, Guile As SHell. -Gash is work in progress; many language constructs work, pipes work, -some redirections work. +Gash is work in progress; many language constructs work, globbing +mostly works, pipes work, some redirections work. ") (when (or %prefer-builtins? (not (PATH-search-path "ls"))) (display "\nIt features the following, somewhat naive builtin commands\n") diff --git a/gash/guix-build-utils.scm b/gash/guix-build-utils.scm index 896cc6d..002e43b 100644 --- a/gash/guix-build-utils.scm +++ b/gash/guix-build-utils.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As Shell +;;; Gash -- Guile As SHell ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov From 6aa17dd4ac757df9c998d49471200a1e562a6237 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Thu, 5 Jul 2018 06:17:34 +0200 Subject: [PATCH 107/312] cat: Support multiple arguments, support "-" * gash/bournish-commands.scm (cat-implementation): Support multiple arguments, support "-". (wrap-command): New function. --- gash/bournish-commands.scm | 51 +++++++++++++++++++------------------- gash/gash.scm | 12 +++------ 2 files changed, 30 insertions(+), 33 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 1c1ae52..34ac531 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -36,6 +36,7 @@ rm-command wc-command which-command + wrap-command )) ;;; Commentary: @@ -49,13 +50,13 @@ ;;; ;;; Code: -(define (expand-variable str) - "Return STR or code to obtain the value of the environment variable STR -refers to." - ;; XXX: No support for "${VAR}". - (if (string-prefix? "$" str) - `(or (getenv ,(string-drop str 1)) "") - str)) +(define (wrap-command command name) + (lambda args + (catch #t + (cut apply command args) + (lambda (key . args) + (format (current-error-port) "~a: ~a ~a\n" name key args) + 1)))) (define* (display-tabulated lst #:key @@ -125,30 +126,30 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." files))) (display-tabulated files))))) -(define (ls-command . files) - (apply ls-command-implementation files)) +(define ls-command (wrap-command ls-command-implementation "ls")) (define (which-command program . rest) (stdout (search-path (executable-path) program))) -(define (cat-command file . rest) - (call-with-input-file file - (lambda (port) - (dump-port port (current-output-port)) - *unspecified*))) +(define (cat-command-implementation . args) + (fold (lambda (file p) + (if (string=? file "-") (dump-port (current-input-port) (current-output-port)) + (call-with-input-file file + (lambda (port) + (dump-port port (current-output-port)))))) + 0 args)) -(define (rm-command . args) +(define cat-command (wrap-command cat-command-implementation "cat")) + +(define (rm-command-implementation . args) "Emit code for the 'rm' command." - (catch #t - (lambda _ - (cond ((member "-r" args) - (for-each delete-file-recursively - (apply delete (cons "-r" args)))) - (else - (for-each delete-file args)))) - (lambda (key . args) - (format (current-error-port) "rm: ~a ~a\n" key args) - 1))) + (cond ((member "-r" args) + (for-each delete-file-recursively + (apply delete (cons "-r" args)))) + (else + (for-each delete-file args)))) + +(define rm-command (wrap-command rm-command-implementation "rm")) (define (lines+chars port) "Return the number of lines and number of chars read from PORT." diff --git a/gash/gash.scm b/gash/gash.scm index 08fb694..f411462 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -257,14 +257,10 @@ mostly works, pipes work, some redirections work. (display "\nIt features the following, somewhat naive builtin commands\n") (display-tabulated (map car %commands)))) -(define (cp-command source dest . rest) - (catch #t - (lambda _ - (copy-file source dest) - 0) - (lambda (key . args) - (format (current-error-port) "cp: ~a ~a\n" key args) - 1))) +(define (cp-command-implementation source dest . rest) + (copy-file source dest)) + +(define cp-command (wrap-command cp-command-implementation "cp")) (define (set-shell-opt! name set?) (let* ((shell-opts (assoc-ref global-variables "SHELLOPTS")) From 9f8daa3d3c4209053af1a3d9ec95a791c3c29d0b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 10 Jul 2018 00:11:24 +0200 Subject: [PATCH 108/312] guix: resurrect package build. --- makefile | 2 +- {test => todo}/for.sh | 0 {test => todo}/ifthen.sh | 0 {test => todo}/ifthenelse.sh | 0 {test => todo}/test.sh | 0 5 files changed, 1 insertion(+), 1 deletion(-) rename {test => todo}/for.sh (100%) rename {test => todo}/ifthen.sh (100%) rename {test => todo}/ifthenelse.sh (100%) rename {test => todo}/test.sh (100%) diff --git a/makefile b/makefile index e0cfad9..90650dd 100644 --- a/makefile +++ b/makefile @@ -28,7 +28,7 @@ ifneq ($(BASH),) endif check-gash: all - ./test.sh + SHELL=bin/gash ./test.sh install: all mkdir -p $(DESTDIR)$(BINDIR) diff --git a/test/for.sh b/todo/for.sh similarity index 100% rename from test/for.sh rename to todo/for.sh diff --git a/test/ifthen.sh b/todo/ifthen.sh similarity index 100% rename from test/ifthen.sh rename to todo/ifthen.sh diff --git a/test/ifthenelse.sh b/todo/ifthenelse.sh similarity index 100% rename from test/ifthenelse.sh rename to todo/ifthenelse.sh diff --git a/test/test.sh b/todo/test.sh similarity index 100% rename from test/test.sh rename to todo/test.sh From 859a95efe29187c48028630ffa9211f2533b5ee3 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 10 Jul 2018 00:11:50 +0200 Subject: [PATCH 109/312] doc: Add skeleton. --- .gitignore | 3 +- configure | 6 + doc/fdl-1.3.texi | 505 ++++++++++++++++++++++++++++++++++++++++ doc/gash.info | 588 +++++++++++++++++++++++++++++++++++++++++++++++ doc/gash.texi | 121 ++++++++++ guix.scm | 8 +- makefile | 18 ++ 7 files changed, 1244 insertions(+), 5 deletions(-) create mode 100644 doc/fdl-1.3.texi create mode 100644 doc/gash.info create mode 100644 doc/gash.texi diff --git a/.gitignore b/.gitignore index 301bb29..eb10f8d 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ *.go *~ /bin/gash -/.config.make \ No newline at end of file +/.config.make +/doc/version.texi diff --git a/configure b/configure index bced961..261e62a 100755 --- a/configure +++ b/configure @@ -1,5 +1,7 @@ #! /bin/sh +VERSION=0.1 + # parse --prefix=PREFIX, mainly for GuixSD/Debian cmdline=$(echo "$@") PREFIX=${cmdline##*--prefix=} @@ -15,6 +17,7 @@ GUILE_TOOLS=$(command -v guile-tools) GUILE_SITE_DIR=$PREFIX/share/guile/site/$GUILE_EFFECTIVE_VERSION GUILE_SITE_CCACHE_DIR=$PREFIX/lib/guile/$GUILE_EFFECTIVE_VERSION/site-ccache GUILE_EFFECTIVE_VERSION=$(guile -c '(display (effective-version))') +MAKEINFO=$(command -v makeinfo) sed \ -e s,@GUILE@,$GUILE,\ @@ -32,6 +35,9 @@ DOCDIR=$PREFIX/share/doc/gash GUILE_EFFECTIVE_VERSION=$GUILE_EFFECTIVE_VERSION GUILE_SITE_DIR=$GUILE_SITE_DIR GUILE_SITE_CCACHE_DIR=$GUILE_SITE_CCACHE_DIR +MAKEINFO=$MAKEINFO +SHELL=$BASH +VERSION=$VERSION EOF cat < + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + 0. PREAMBLE + + The purpose of this License is to make a manual, textbook, or other + functional and useful document “free” in the sense of freedom: to + assure everyone the effective freedom to copy and redistribute it, + with or without modifying it, either commercially or + noncommercially. Secondarily, this License preserves for the + author and publisher a way to get credit for their work, while not + being considered responsible for modifications made by others. + + This License is a kind of “copyleft”, which means that derivative + works of the document must themselves be free in the same sense. + It complements the GNU General Public License, which is a copyleft + license designed for free software. + + We have designed this License in order to use it for manuals for + free software, because free software needs free documentation: a + free program should come with manuals providing the same freedoms + that the software does. But this License is not limited to + software manuals; it can be used for any textual work, regardless + of subject matter or whether it is published as a printed book. We + recommend this License principally for works whose purpose is + instruction or reference. + + 1. APPLICABILITY AND DEFINITIONS + + This License applies to any manual or other work, in any medium, + that contains a notice placed by the copyright holder saying it can + be distributed under the terms of this License. Such a notice + grants a world-wide, royalty-free license, unlimited in duration, + to use that work under the conditions stated herein. The + “Document”, below, refers to any such manual or work. Any member + of the public is a licensee, and is addressed as “you”. You accept + the license if you copy, modify or distribute the work in a way + requiring permission under copyright law. + + A “Modified Version” of the Document means any work containing the + Document or a portion of it, either copied verbatim, or with + modifications and/or translated into another language. + + A “Secondary Section” is a named appendix or a front-matter section + of the Document that deals exclusively with the relationship of the + publishers or authors of the Document to the Document’s overall + subject (or to related matters) and contains nothing that could + fall directly within that overall subject. (Thus, if the Document + is in part a textbook of mathematics, a Secondary Section may not + explain any mathematics.) The relationship could be a matter of + historical connection with the subject or with related matters, or + of legal, commercial, philosophical, ethical or political position + regarding them. + + The “Invariant Sections” are certain Secondary Sections whose + titles are designated, as being those of Invariant Sections, in the + notice that says that the Document is released under this License. + If a section does not fit the above definition of Secondary then it + is not allowed to be designated as Invariant. The Document may + contain zero Invariant Sections. If the Document does not identify + any Invariant Sections then there are none. + + The “Cover Texts” are certain short passages of text that are + listed, as Front-Cover Texts or Back-Cover Texts, in the notice + that says that the Document is released under this License. A + Front-Cover Text may be at most 5 words, and a Back-Cover Text may + be at most 25 words. + + A “Transparent” copy of the Document means a machine-readable copy, + represented in a format whose specification is available to the + general public, that is suitable for revising the document + straightforwardly with generic text editors or (for images composed + of pixels) generic paint programs or (for drawings) some widely + available drawing editor, and that is suitable for input to text + formatters or for automatic translation to a variety of formats + suitable for input to text formatters. A copy made in an otherwise + Transparent file format whose markup, or absence of markup, has + been arranged to thwart or discourage subsequent modification by + readers is not Transparent. An image format is not Transparent if + used for any substantial amount of text. A copy that is not + “Transparent” is called “Opaque”. + + Examples of suitable formats for Transparent copies include plain + ASCII without markup, Texinfo input format, LaTeX input format, + SGML or XML using a publicly available DTD, and standard-conforming + simple HTML, PostScript or PDF designed for human modification. + Examples of transparent image formats include PNG, XCF and JPG. + Opaque formats include proprietary formats that can be read and + edited only by proprietary word processors, SGML or XML for which + the DTD and/or processing tools are not generally available, and + the machine-generated HTML, PostScript or PDF produced by some word + processors for output purposes only. + + The “Title Page” means, for a printed book, the title page itself, + plus such following pages as are needed to hold, legibly, the + material this License requires to appear in the title page. For + works in formats which do not have any title page as such, “Title + Page” means the text near the most prominent appearance of the + work’s title, preceding the beginning of the body of the text. + + The “publisher” means any person or entity that distributes copies + of the Document to the public. + + A section “Entitled XYZ” means a named subunit of the Document + whose title either is precisely XYZ or contains XYZ in parentheses + following text that translates XYZ in another language. (Here XYZ + stands for a specific section name mentioned below, such as + “Acknowledgements”, “Dedications”, “Endorsements”, or “History”.) + To “Preserve the Title” of such a section when you modify the + Document means that it remains a section “Entitled XYZ” according + to this definition. + + The Document may include Warranty Disclaimers next to the notice + which states that this License applies to the Document. These + Warranty Disclaimers are considered to be included by reference in + this License, but only as regards disclaiming warranties: any other + implication that these Warranty Disclaimers may have is void and + has no effect on the meaning of this License. + + 2. VERBATIM COPYING + + You may copy and distribute the Document in any medium, either + commercially or noncommercially, provided that this License, the + copyright notices, and the license notice saying this License + applies to the Document are reproduced in all copies, and that you + add no other conditions whatsoever to those of this License. You + may not use technical measures to obstruct or control the reading + or further copying of the copies you make or distribute. However, + you may accept compensation in exchange for copies. If you + distribute a large enough number of copies you must also follow the + conditions in section 3. + + You may also lend copies, under the same conditions stated above, + and you may publicly display copies. + + 3. COPYING IN QUANTITY + + If you publish printed copies (or copies in media that commonly + have printed covers) of the Document, numbering more than 100, and + the Document’s license notice requires Cover Texts, you must + enclose the copies in covers that carry, clearly and legibly, all + these Cover Texts: Front-Cover Texts on the front cover, and + Back-Cover Texts on the back cover. Both covers must also clearly + and legibly identify you as the publisher of these copies. The + front cover must present the full title with all words of the title + equally prominent and visible. You may add other material on the + covers in addition. Copying with changes limited to the covers, as + long as they preserve the title of the Document and satisfy these + conditions, can be treated as verbatim copying in other respects. + + If the required texts for either cover are too voluminous to fit + legibly, you should put the first ones listed (as many as fit + reasonably) on the actual cover, and continue the rest onto + adjacent pages. + + If you publish or distribute Opaque copies of the Document + numbering more than 100, you must either include a machine-readable + Transparent copy along with each Opaque copy, or state in or with + each Opaque copy a computer-network location from which the general + network-using public has access to download using public-standard + network protocols a complete Transparent copy of the Document, free + of added material. If you use the latter option, you must take + reasonably prudent steps, when you begin distribution of Opaque + copies in quantity, to ensure that this Transparent copy will + remain thus accessible at the stated location until at least one + year after the last time you distribute an Opaque copy (directly or + through your agents or retailers) of that edition to the public. + + It is requested, but not required, that you contact the authors of + the Document well before redistributing any large number of copies, + to give them a chance to provide you with an updated version of the + Document. + + 4. MODIFICATIONS + + You may copy and distribute a Modified Version of the Document + under the conditions of sections 2 and 3 above, provided that you + release the Modified Version under precisely this License, with the + Modified Version filling the role of the Document, thus licensing + distribution and modification of the Modified Version to whoever + possesses a copy of it. In addition, you must do these things in + the Modified Version: + + A. Use in the Title Page (and on the covers, if any) a title + distinct from that of the Document, and from those of previous + versions (which should, if there were any, be listed in the + History section of the Document). You may use the same title + as a previous version if the original publisher of that + version gives permission. + + B. List on the Title Page, as authors, one or more persons or + entities responsible for authorship of the modifications in + the Modified Version, together with at least five of the + principal authors of the Document (all of its principal + authors, if it has fewer than five), unless they release you + from this requirement. + + C. State on the Title page the name of the publisher of the + Modified Version, as the publisher. + + D. Preserve all the copyright notices of the Document. + + E. Add an appropriate copyright notice for your modifications + adjacent to the other copyright notices. + + F. Include, immediately after the copyright notices, a license + notice giving the public permission to use the Modified + Version under the terms of this License, in the form shown in + the Addendum below. + + G. Preserve in that license notice the full lists of Invariant + Sections and required Cover Texts given in the Document’s + license notice. + + H. Include an unaltered copy of this License. + + I. Preserve the section Entitled “History”, Preserve its Title, + and add to it an item stating at least the title, year, new + authors, and publisher of the Modified Version as given on the + Title Page. If there is no section Entitled “History” in the + Document, create one stating the title, year, authors, and + publisher of the Document as given on its Title Page, then add + an item describing the Modified Version as stated in the + previous sentence. + + J. Preserve the network location, if any, given in the Document + for public access to a Transparent copy of the Document, and + likewise the network locations given in the Document for + previous versions it was based on. These may be placed in the + “History” section. You may omit a network location for a work + that was published at least four years before the Document + itself, or if the original publisher of the version it refers + to gives permission. + + K. For any section Entitled “Acknowledgements” or “Dedications”, + Preserve the Title of the section, and preserve in the section + all the substance and tone of each of the contributor + acknowledgements and/or dedications given therein. + + L. Preserve all the Invariant Sections of the Document, unaltered + in their text and in their titles. Section numbers or the + equivalent are not considered part of the section titles. + + M. Delete any section Entitled “Endorsements”. Such a section + may not be included in the Modified Version. + + N. Do not retitle any existing section to be Entitled + “Endorsements” or to conflict in title with any Invariant + Section. + + O. Preserve any Warranty Disclaimers. + + If the Modified Version includes new front-matter sections or + appendices that qualify as Secondary Sections and contain no + material copied from the Document, you may at your option designate + some or all of these sections as invariant. To do this, add their + titles to the list of Invariant Sections in the Modified Version’s + license notice. These titles must be distinct from any other + section titles. + + You may add a section Entitled “Endorsements”, provided it contains + nothing but endorsements of your Modified Version by various + parties—for example, statements of peer review or that the text has + been approved by an organization as the authoritative definition of + a standard. + + You may add a passage of up to five words as a Front-Cover Text, + and a passage of up to 25 words as a Back-Cover Text, to the end of + the list of Cover Texts in the Modified Version. Only one passage + of Front-Cover Text and one of Back-Cover Text may be added by (or + through arrangements made by) any one entity. If the Document + already includes a cover text for the same cover, previously added + by you or by arrangement made by the same entity you are acting on + behalf of, you may not add another; but you may replace the old + one, on explicit permission from the previous publisher that added + the old one. + + The author(s) and publisher(s) of the Document do not by this + License give permission to use their names for publicity for or to + assert or imply endorsement of any Modified Version. + + 5. COMBINING DOCUMENTS + + You may combine the Document with other documents released under + this License, under the terms defined in section 4 above for + modified versions, provided that you include in the combination all + of the Invariant Sections of all of the original documents, + unmodified, and list them all as Invariant Sections of your + combined work in its license notice, and that you preserve all + their Warranty Disclaimers. + + The combined work need only contain one copy of this License, and + multiple identical Invariant Sections may be replaced with a single + copy. If there are multiple Invariant Sections with the same name + but different contents, make the title of each such section unique + by adding at the end of it, in parentheses, the name of the + original author or publisher of that section if known, or else a + unique number. Make the same adjustment to the section titles in + the list of Invariant Sections in the license notice of the + combined work. + + In the combination, you must combine any sections Entitled + “History” in the various original documents, forming one section + Entitled “History”; likewise combine any sections Entitled + “Acknowledgements”, and any sections Entitled “Dedications”. You + must delete all sections Entitled “Endorsements.” + + 6. COLLECTIONS OF DOCUMENTS + + You may make a collection consisting of the Document and other + documents released under this License, and replace the individual + copies of this License in the various documents with a single copy + that is included in the collection, provided that you follow the + rules of this License for verbatim copying of each of the documents + in all other respects. + + You may extract a single document from such a collection, and + distribute it individually under this License, provided you insert + a copy of this License into the extracted document, and follow this + License in all other respects regarding verbatim copying of that + document. + + 7. AGGREGATION WITH INDEPENDENT WORKS + + A compilation of the Document or its derivatives with other + separate and independent documents or works, in or on a volume of a + storage or distribution medium, is called an “aggregate” if the + copyright resulting from the compilation is not used to limit the + legal rights of the compilation’s users beyond what the individual + works permit. When the Document is included in an aggregate, this + License does not apply to the other works in the aggregate which + are not themselves derivative works of the Document. + + If the Cover Text requirement of section 3 is applicable to these + copies of the Document, then if the Document is less than one half + of the entire aggregate, the Document’s Cover Texts may be placed + on covers that bracket the Document within the aggregate, or the + electronic equivalent of covers if the Document is in electronic + form. Otherwise they must appear on printed covers that bracket + the whole aggregate. + + 8. TRANSLATION + + Translation is considered a kind of modification, so you may + distribute translations of the Document under the terms of section + 4. Replacing Invariant Sections with translations requires special + permission from their copyright holders, but you may include + translations of some or all Invariant Sections in addition to the + original versions of these Invariant Sections. You may include a + translation of this License, and all the license notices in the + Document, and any Warranty Disclaimers, provided that you also + include the original English version of this License and the + original versions of those notices and disclaimers. In case of a + disagreement between the translation and the original version of + this License or a notice or disclaimer, the original version will + prevail. + + If a section in the Document is Entitled “Acknowledgements”, + “Dedications”, or “History”, the requirement (section 4) to + Preserve its Title (section 1) will typically require changing the + actual title. + + 9. TERMINATION + + You may not copy, modify, sublicense, or distribute the Document + except as expressly provided under this License. Any attempt + otherwise to copy, modify, sublicense, or distribute it is void, + and will automatically terminate your rights under this License. + + However, if you cease all violation of this License, then your + license from a particular copyright holder is reinstated (a) + provisionally, unless and until the copyright holder explicitly and + finally terminates your license, and (b) permanently, if the + copyright holder fails to notify you of the violation by some + reasonable means prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is + reinstated permanently if the copyright holder notifies you of the + violation by some reasonable means, this is the first time you have + received notice of violation of this License (for any work) from + that copyright holder, and you cure the violation prior to 30 days + after your receipt of the notice. + + Termination of your rights under this section does not terminate + the licenses of parties who have received copies or rights from you + under this License. If your rights have been terminated and not + permanently reinstated, receipt of a copy of some or all of the + same material does not give you any rights to use it. + + 10. FUTURE REVISIONS OF THIS LICENSE + + The Free Software Foundation may publish new, revised versions of + the GNU Free Documentation License from time to time. Such new + versions will be similar in spirit to the present version, but may + differ in detail to address new problems or concerns. See + . + + Each version of the License is given a distinguishing version + number. If the Document specifies that a particular numbered + version of this License “or any later version” applies to it, you + have the option of following the terms and conditions either of + that specified version or of any later version that has been + published (not as a draft) by the Free Software Foundation. If the + Document does not specify a version number of this License, you may + choose any version ever published (not as a draft) by the Free + Software Foundation. If the Document specifies that a proxy can + decide which future versions of this License can be used, that + proxy’s public statement of acceptance of a version permanently + authorizes you to choose that version for the Document. + + 11. RELICENSING + + “Massive Multiauthor Collaboration Site” (or “MMC Site”) means any + World Wide Web server that publishes copyrightable works and also + provides prominent facilities for anybody to edit those works. A + public wiki that anybody can edit is an example of such a server. + A “Massive Multiauthor Collaboration” (or “MMC”) contained in the + site means any set of copyrightable works thus published on the MMC + site. + + “CC-BY-SA” means the Creative Commons Attribution-Share Alike 3.0 + license published by Creative Commons Corporation, a not-for-profit + corporation with a principal place of business in San Francisco, + California, as well as future copyleft versions of that license + published by that same organization. + + “Incorporate” means to publish or republish a Document, in whole or + in part, as part of another Document. + + An MMC is “eligible for relicensing” if it is licensed under this + License, and if all works that were first published under this + License somewhere other than this MMC, and subsequently + incorporated in whole or in part into the MMC, (1) had no cover + texts or invariant sections, and (2) were thus incorporated prior + to November 1, 2008. + + The operator of an MMC Site may republish an MMC contained in the + site under CC-BY-SA on the same site at any time before August 1, + 2009, provided the MMC is eligible for relicensing. + +ADDENDUM: How to use this License for your documents +==================================================== + +To use this License in a document you have written, include a copy of +the License in the document and put the following copyright and license +notices just after the title page: + + Copyright (C) YEAR YOUR NAME. + Permission is granted to copy, distribute and/or modify this document + under the terms of the GNU Free Documentation License, Version 1.3 + or any later version published by the Free Software Foundation; + with no Invariant Sections, no Front-Cover Texts, and no Back-Cover + Texts. A copy of the license is included in the section entitled ``GNU + Free Documentation License''. + + If you have Invariant Sections, Front-Cover Texts and Back-Cover +Texts, replace the “with...Texts.” line with this: + + with the Invariant Sections being LIST THEIR TITLES, with + the Front-Cover Texts being LIST, and with the Back-Cover Texts + being LIST. + + If you have Invariant Sections without Cover Texts, or some other +combination of the three, merge those two alternatives to suit the +situation. + + If your document contains nontrivial examples of program code, we +recommend releasing these examples in parallel under your choice of free +software license, such as the GNU General Public License, to permit +their use in free software. + + +File: gash.info, Node: Concept Index, Next: Programming Index, Prev: GNU Free Documentation License, Up: Top + +Concept Index +************* + +[index] +* Menu: + +* license, GNU Free Documentation License: GNU Free Documentation License. + (line 6) +* repl: Invoking Gash. (line 6) + + +File: gash.info, Node: Programming Index, Prev: Concept Index, Up: Top + +Programming Index +***************** + + + +Tag Table: +Node: Top668 +Node: Introduction1144 +Node: Invoking Gash1304 +Node: GNU Free Documentation License1765 +Node: Concept Index27121 +Node: Programming Index27509 + +End Tag Table + + +Local Variables: +coding: utf-8 +End: diff --git a/doc/gash.texi b/doc/gash.texi new file mode 100644 index 0000000..d818591 --- /dev/null +++ b/doc/gash.texi @@ -0,0 +1,121 @@ +\input texinfo +@c -*- mode: texinfo; -*- + +@c %**start of header +@setfilename gash.info +@documentencoding UTF-8 +@settitle Gash Reference Manual +@c %**end of header + +@include version.texi + +@copying +Copyright @copyright{} 2018 Rutger EW van Beusekom@* + +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.3 or +any later version published by the Free Software Foundation; with no +Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A +copy of the license is included in the section entitled ``GNU Free +Documentation License''. +@end copying + +@dircategory Basics +@direntry +* Gash: (gash). Guile As SHell. +* gash: (gash)Invoking gash. Running Gash, a minimalist Bash lookalike. +@end direntry + +@titlepage +@title Gash Reference Manual +@subtitle A POSIX-compliant sh replacement in Guile Scheme. +@author Jan (janneke) Nieuwenhuizen + +@page +@vskip 0pt plus 1filll +Edition @value{EDITION} @* +@value{UPDATED} @* + +@insertcopying +@end titlepage + +@contents + +@c ********************************************************************* +@node Top +@top Gash + +This document describes Gash version @value{VERSION}, a +POSIX-compliant sh replacement in Guile Scheme. + +@menu +* Introduction:: What is Gash about? +* GNU Free Documentation License:: The license of this manual. +* Concept Index:: Concepts. +* Programming Index:: Data types, functions, and variables. + +@detailmenu + --- The Detailed Node Listing --- + +Introduction + +* Invoking Gash:: + +@end detailmenu +@end menu + +@c ********************************************************************* +@node Introduction +@chapter Introduction + +@menu +* Invoking Gash:: +@end menu + +@node Invoking Gash +@section Invoking Gash + +@cindex repl +The @command{gash} command is the sh interpreter. + +@example +gash @var{option}@dots{} @file{FILE} +@end example + +The @var{option}s can be among the following: + +@table @code + +@item -c @var{string} +By default, Gash will read a file named on the command line as a script. + +@item -h@r{, }--help +Display help on invoking Gash, and then exit. + +@item -v@r{, }--version +Display the current version of Gash, and then exit. + +@end table + +@c ********************************************************************* +@node GNU Free Documentation License +@appendix GNU Free Documentation License +@cindex license, GNU Free Documentation License +@include fdl-1.3.texi + +@c ********************************************************************* +@node Concept Index +@unnumbered Concept Index +@printindex cp + +@node Programming Index +@unnumbered Programming Index +@syncodeindex tp fn +@syncodeindex vr fn +@printindex fn + +@bye + +@c Local Variables: +@c ispell-local-dictionary: "american"; +@c End: diff --git a/guix.scm b/guix.scm index 8926746..15b0c88 100644 --- a/guix.scm +++ b/guix.scm @@ -46,13 +46,11 @@ (ice-9 rdelim) (gnu packages) (gnu packages base) - (gnu packages commencement) - (gnu packages cross-base) - (gnu packages gcc) + (gnu packages bash) (gnu packages guile) (gnu packages mes) (gnu packages package-management) - (gnu packages perl) + (gnu packages texinfo) ((guix build utils) #:select (with-directory-excursion)) (guix build-system gnu) (guix build-system trivial) @@ -101,6 +99,8 @@ `(("guile-readline" ,guile-readline))) (inputs `(("guile" ,guile-2.2))) + (native-inputs + `(("texinfo" ,texinfo))) (synopsis "A POSIX compliant sh replacement for Guile.") (description "Gash [Guile As Shell] aims to produce at least a POSIX compliant sh replacement diff --git a/makefile b/makefile index 90650dd..d6bc588 100644 --- a/makefile +++ b/makefile @@ -40,6 +40,24 @@ install: all tar -cf- gash/*.go | tar -C $(DESTDIR)$(GUILE_SITE_CCACHE_DIR) -xf- mkdir -p $(DESTDIR)$(DOCDIR) cp -f COPYING README TODO $(DOCDIR) + $(MAKE) install-info + +install-info: info + mkdir -p $(DESTDIR)$(PREFIX)/share/info + tar -cf- doc/gash.info* | tar -xf- --strip-components=1 -C $(DESTDIR)$(PREFIX)/share/info + install-info --info-dir=$(DESTDIR)$(PREFIX)/share/info doc/gash.info + +doc/version.texi: doc/gash.texi makefile + (set `LANG= date -r $< +'%d %B %Y'`;\ + echo "@set UPDATED $$1 $$2 $$3"; \ + echo "@set UPDATED-MONTH $$2 $$3"; \ + echo "@set EDITION $(VERSION)"; \ + echo "@set VERSION $(VERSION)") > $@ + +info: doc/gash.info + +doc/gash.info: doc/gash.texi doc/version.texi makefile + $(MAKEINFO) -o $@ -I doc $< define HELP_TOP Usage: make [OPTION]... [TARGET]... From 745757cfd0f5ca99cf61496c5adec62c698272d7 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sat, 7 Jul 2018 19:32:46 +0200 Subject: [PATCH 110/312] WIP FOO => rewrite me harder --- gash/gash.scm | 106 +++++++++++++++++++++++++------------------------- gash/io.scm | 6 ++- gash/peg.scm | 42 ++++++++++++++++++-- 3 files changed, 95 insertions(+), 59 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index f411462..efb64b4 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -92,7 +92,6 @@ copyleft. (debug (single-char #\d)) (errexit (single-char #\e)) (help (single-char #\h)) - (parse (single-char #\p)) (prefer-builtins) (version (single-char #\v)) (xtrace (single-char #\x)))) @@ -100,19 +99,13 @@ copyleft. (command? (option-ref options 'command #f)) (opt? (lambda (name) (lambda (o) (and (eq? (car o) name) (cdr o))))) (debug (length (filter-map (opt? 'debug) options))) + (debug? (option-ref options 'debug #f)) (help? (option-ref options 'help #f)) - (parse? (option-ref options 'parse #f)) (version? (option-ref options 'version #f)) (files (option-ref options '() '())) - (run - (lambda (ast) - (cond (parse? - (let ((ast- (transform ast))) - (stdout "parsed: " ast) - (stdout "prepared: " ast-) - #t)) - (#t - (sh-exec ast)))))) + (run (compose sh-exec + (if #t (cut stdout "transformed: " <>) identity) (cut transform <>) + (if #t (cut stdout "parsed: " <>) identity)))) (set! %prefer-builtins? (option-ref options 'prefer-builtins #f)) (set-shell-opt! "errexit" (option-ref options 'errexit #f)) (set-shell-opt! "xtrace" (option-ref options 'xtrace #f)) @@ -185,7 +178,7 @@ copyleft. paths))) (cond ((not pattern) '("")) - ((string=? "$?" pattern) (list (assoc-ref global-variables "?"))) + ((string-prefix? "$" pattern) (list (pk "get " pattern " => " (assoc-ref global-variables (string-drop pattern 1))))) ;; TODO: REMOVE ME ((glob? pattern) (let ((absolute? (string-prefix? "/" pattern))) (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) (paths (if absolute? '("/") '(".")))) @@ -320,52 +313,57 @@ mostly works, pipes work, some redirections work. (#t #t) (_ #f))))))) +(define (tostring . args) + (with-output-to-string (cut map display args))) + ;; transform ast -> list of expr ;; such that (map eval expr) - (define (transform ast) (match ast - (('script term "&") (list (background (transform term)))) - (('script term) `(,(transform term))) - (('script terms ...) (transform terms)) - (('substitution "$(" script ")") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment))) - (('substitution "`" script "`") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment))) - ((('term command)) `(,(transform command))) - ((('term command) ...) (map transform command)) - ((('term command) (('term commands) ...)) (map transform (cons command commands))) - (('compound-list terms ...) (transform terms)) - (('if-clause "if" (expression "then" consequent "fi")) - `(if (equal? 0 (status:exit-val ,@(transform expression))) - (begin ,@(transform consequent)))) - (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) - `(if (equal? 0 (status:exit-val ,@(transform expression))) - (begin ,@(transform consequent)) - (begin ,@(transform alternative)))) - (('for-clause ("for" identifier sep do-group)) #t) - (('for-clause "for" ((identifier "in" lst sep) do-group)) - `(for-each (lambda (,(string->symbol identifier)) - (begin ,@(expand identifier (transform do-group)))) - (glob ,(transform lst)))) - (('do-group "do" (command "done")) (transform command)) - (('pipeline command) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,@command)))) - (('pipeline command piped-commands) `(pipeline #t ,@(transform command) ,@(transform piped-commands))) - (('simple-command ('word (assignment name value))) (set! global-variables (assoc-set! global-variables (transform name) (transform value))) #t) - (('simple-command ('word s)) `((glob ,(transform s)))) - (('simple-command ('word s1) ('io-redirect "<<" ('here-document s2))) `((append (glob "echo") (cons "-n" (glob ,s2))) (glob ,(transform s1)))) - (('simple-command ('word s1) ('word s2)) `((append (glob ,(transform s1)) (glob ,(transform s2))))) - (('simple-command ('word s1) (('word s2) ...)) `((append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2)))))) - (('variable s) (assoc-ref global-variables (string-drop s 1))) - (('literal s) (transform s)) - (('singlequotes s) (string-concatenate `("'" ,s "'"))) - (('doublequotes s) (string-concatenate `("\"" ,s "\""))) - (('backticks s) (string-concatenate `("`" ,s "`"))) - (('delim ('singlequotes s ...)) (string-concatenate (map transform s))) - (('delim ('doublequotes s ...)) (string-concatenate (map transform s))) - (('delim ('backticks s ...)) (string-concatenate (map transform s))) - ((('pipe _) command) (transform command)) - (((('pipe _) command) ...) (map (compose car transform) command)) - ((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...) - (_ ast))) ;; done + (('script term "&") (list (background (transform term)))) + (('script term) `(,(transform term))) + (('script terms ...) (transform terms)) + (('substitution "$(" script ")") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment))) + (('substitution "`" script "`") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment))) + ((('term command)) `(,(transform command))) + ((('term command) ...) (map transform command)) + ((('term command) (('term commands) ...)) (map transform (cons command commands))) + (('compound-list terms ...) (transform terms)) + (('if-clause "if" (expression "then" consequent "fi")) + `(if (equal? 0 (status:exit-val ,@(transform expression))) + (begin ,@(transform consequent)))) + (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) + `(if (equal? 0 (status:exit-val ,@(transform expression))) + (begin ,@(transform consequent)) + (begin ,@(transform alternative)))) + (('for-clause ("for" identifier sep do-group)) #t) + (('for-clause "for" ((identifier "in" lst sep) do-group)) + `(for-each (lambda (,(string->symbol identifier)) + (begin ,@(expand identifier (transform do-group)))) + (glob ,(transform lst)))) + (('do-group "do" (command "done")) (transform command)) + (('pipeline command) (pk 1) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,@command)))) + (('pipeline command piped-commands) (pk 2) `(pipeline #t ,@(transform command) ,@(transform piped-commands))) + (('simple-command ('word (assignment name value))) `((lambda _ (let ((name ,(tostring (transform name))) + (value ,(tostring (transform value)))) + (stderr "assignment: " name "=" value) + (set! global-variables (assoc-set! global-variables name (glob value))))))) + (('simple-command ('word s)) `((glob ,(transform s)))) + (('simple-command ('word s1) ('io-redirect "<<" ('here-document s2))) `((append (glob "echo") (cons "-n" (glob ,s2))) (glob ,(transform s1)))) + (('simple-command ('word s1) ('word s2)) `((append (glob ,(transform s1)) (glob ,(transform s2))))) + (('simple-command ('word s1) (('word s2) ...)) `((append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2)))))) + (('variable s) s) + (('literal s) (transform s)) + (('singlequotes s) (string-concatenate `("'" ,s "'"))) + (('doublequotes s) (string-concatenate `("\"" ,s "\""))) + (('backticks s) (string-concatenate `("`" ,s "`"))) + (('delim ('singlequotes s ...)) (string-concatenate (map transform s))) + (('delim ('doublequotes s ...)) (string-concatenate (map transform s))) + (('delim ('backticks s ...)) (string-concatenate (map transform s))) + ((('pipe _) command) (transform command)) + (((('pipe _) command) ...) (map (compose car transform) command)) + ((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...) + (_ ast))) ;; done (define (sh-exec ast) (define (exec cmd) diff --git a/gash/io.scm b/gash/io.scm index e5dc37a..e14eebe 100644 --- a/gash/io.scm +++ b/gash/io.scm @@ -1,5 +1,7 @@ (define-module (gash io) + #:use-module (srfi srfi-1) + #:export (stdout stderr)) (define (output port o) @@ -9,8 +11,8 @@ (define (stdout . o) (output (current-output-port) o) - o) + (last o)) (define (stderr . o) (output (current-error-port) o) - o) + (last o)) diff --git a/gash/peg.scm b/gash/peg.scm index 8099960..8e476c5 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -5,6 +5,42 @@ #:export (parse peg-trace?)) +(define (wrap-parser-for-users for-syntax parser accumsym s-syn) + #`(lambda (str strlen pos) + (when (> (@ (gash gash) %debug-level) 0) + (format (current-error-port) "~a ~a : ~s\n" + (make-string (- pos (or (string-rindex str #\newline 0 pos) 0)) #\space) + '#,s-syn + (substring str pos (min (+ pos 40) strlen)))) + + (let* ((res (#,parser str strlen pos))) + ;; Try to match the nonterminal. + (if res + ;; If we matched, do some post-processing to figure out + ;; what data to propagate upward. + (let ((at (car res)) + (body (cadr res))) + #,(cond + ((eq? accumsym 'name) + #`(list at '#,s-syn)) + ((eq? accumsym 'all) + #`(list (car res) + (cond + ((not (list? body)) + (list '#,s-syn body)) + ((null? body) '#,s-syn) + ((symbol? (car body)) + (list '#,s-syn body)) + (else (cons '#,s-syn body))))) + ((eq? accumsym 'none) #`(list (car res) '())) + (else #`(begin res)))) + ;; If we didn't match, just return false. + #f)))) + +(module-define! (resolve-module '(ice-9 peg codegen)) + 'wrap-parser-for-users + wrap-parser-for-users) + (define (error? x) (let loop ((x x)) (if (null? x) #f @@ -83,13 +119,13 @@ assignment <-- name assign (substitution / word)? assign < '=' literal <-- (variable / delim / (![0-9] (![()] !io-op !sp !nl !break !pipe !assign !bt !sq !dq .)+) / ([0-9]+ &separator)) literal* - variable <-- '$' ('$' / '*' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) + variable <-- '$' ('$' / '*' / '?' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) delim <-- singlequotes / doublequotes / substitution sq < ['] dq < [\"] bt < [`] - singlequotes <-- sq (doublequotes / substitution / (!sq .))* sq - doublequotes <-- dq (singlequotes / substitution / (!dq .))* dq + singlequotes <-- sq (doublequotes / (!sq .))* sq + doublequotes <-- dq (singlequotes / substitution / variable / (!dq .))* dq separator <- (sp* break ws*) / ws+ break <- amp / semi !semi sequential-sep <-- (semi !semi ws*) / ws+ From d5e7cb691dbce01b83259d3c479af1cd8adfc525 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Tue, 10 Jul 2018 02:10:15 +0200 Subject: [PATCH 111/312] checkpoint --- gash/gash.scm | 19 ++++++---- gash/peg.scm | 99 ++++++++++++++++++++++++++++++++++++--------------- 2 files changed, 82 insertions(+), 36 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index efb64b4..6887d30 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -3,13 +3,14 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (ice-9 buffered-input) #:use-module (ice-9 ftw) #:use-module (ice-9 getopt-long) #:use-module (ice-9 local-eval) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (ice-9 readline) - #:use-module (ice-9 buffered-input) + #:use-module (ice-9 pretty-print) #:use-module (ice-9 receive) #:use-module (ice-9 regex) @@ -92,6 +93,7 @@ copyleft. (debug (single-char #\d)) (errexit (single-char #\e)) (help (single-char #\h)) + (parse (single-char #\p)) (prefer-builtins) (version (single-char #\v)) (xtrace (single-char #\x)))) @@ -101,11 +103,9 @@ copyleft. (debug (length (filter-map (opt? 'debug) options))) (debug? (option-ref options 'debug #f)) (help? (option-ref options 'help #f)) + (parse? (option-ref options 'parse #f)) (version? (option-ref options 'version #f)) - (files (option-ref options '() '())) - (run (compose sh-exec - (if #t (cut stdout "transformed: " <>) identity) (cut transform <>) - (if #t (cut stdout "parsed: " <>) identity)))) + (files (option-ref options '() '()))) (set! %prefer-builtins? (option-ref options 'prefer-builtins #f)) (set-shell-opt! "errexit" (option-ref options 'errexit #f)) (set-shell-opt! "xtrace" (option-ref options 'xtrace #f)) @@ -115,12 +115,17 @@ copyleft. (help? (display-help)) (version? (display-version)) (command? (let ((ast (string-to-ast command?))) + (pretty-print ast) + (exit 0) (exit (if ast (run ast) 0)))) ((pair? files) (let* ((asts (map file-to-ast files)) - (status (map run asts))) - (quit (every identity status)))) + ;;(status (map pretty-print asts)) + ) + ;;(quit (or #t (every identity status))) + (quit #t) + )) (#t (let* ((HOME (string-append (getenv "HOME") "/.gash_history")) (thunk (lambda () (let loop ((line (readline (prompt)))) diff --git a/gash/peg.scm b/gash/peg.scm index 8e476c5..42c7089 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -1,8 +1,11 @@ (define-module (gash peg) + #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) #:use-module (ice-9 peg) #:use-module (ice-9 peg codegen) + #:use-module (srfi srfi-26) + #:export (parse peg-trace?)) (define (wrap-parser-for-users for-syntax parser accumsym s-syn) @@ -76,41 +79,63 @@ (define-peg-string-patterns "script <-- ws* (term (separator term)* separator?)? - error <-- .* - term <-- pipeline (sp* ('&&' / '||') ws* pipeline)* + term <- pipeline (sp* ('&&' / '||') ws* pipeline)* + pipe < '|' pipeline <-- '!'? sp* command (sp* pipe ws* command)* - pipe <-- '|' - command <-- simple-command / (compound-command (sp+ io-redirect)*) / function-def - compound-command <-- brace-group / subshell / for-clause / case-clause / if-clause / while-clause / until-clause - subshell <-- '(' ne-compound-list ')' - compound-list <-- term (separator term)* - ne-compound-list <-- compound-list separator / error - case-clause <-- 'case' sp+ word ws+ 'in' ws+ case-item* 'esac' - case-item <-- pattern (ne-compound-list? case-sep ws* / error) - case-sep < ';;' - pattern <-- sp* word (sp* '|' sp* word)* sp* ')' sp* - for-clause <-- 'for' (sp+ identifier (ws+ 'in' expression sequential-sep / sp* sequential-sep) do-group / error) - expression <-- sp+ substitution sp* / (sp+ word)* sp* - do-group <-- 'do' ws* (ne-compound-list 'done' / error) - if-clause <-- 'if' (ne-compound-list 'then' ws* ne-compound-list else-part? 'fi' / error) - else-part <-- 'elif' (ne-compound-list 'then' ws* ne-compound-list else-part? / error) / 'else' (ne-compound-list / error) - while-clause <-- 'while' (ne-compound-list do-group / error) - until-clause <-- 'until' (ne-compound-list do-group / error) + command <-- (compound-command (sp+ io-redirect)*) / simple-command / function-def + compound-command <- brace-group / subshell / for-clause / case-clause / if-clause / while-clause / until-clause + simple-command <- (sp* (io-redirect sp+)* nonreserved)+ + nonreserved <- &(reserved word) word / !reserved word + reserved < 'case' / 'esac' / 'if' / 'fi' / 'then' / 'else' / 'elif' / 'for' / 'done' / 'do' / 'until' / 'while' + function-def <-- name sp* '(' sp* ')' ws* (function-body / error) function-body <-- compound-command io-redirect* - brace-group <-- '{' (sp* (compound-list / error) sp* '}' / error) - simple-command <-- (io-redirect sp+)* nonreserved (sp+ (io-redirect / nonreserved))* - reserved < 'case' / 'esac' / 'if' / 'fi' / 'then' / 'else' / 'elif' / 'for' / 'done' / 'do' / 'until' / 'while' - nonreserved <- &(reserved word) word / !reserved word / word + io-redirect <-- [0-9]* sp* (io-here / io-file) io-file <-- ('<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|') sp* ([0-9]+ / filename) io-here <- ('<<' / '<<-') io-suffix here-document io-op < '<<-' / '<<' / '<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|' io-suffix <- sp* here-label sp* nl + + brace-group <-- '{' (sp* (compound-list / error) sp* '}' / error) + subshell <-- '(' compound-list separator ')' + compound-list <- term (separator term)* + + case-keyword < 'case' + case-clause <-- case-keyword sp+ word ws+ 'in' ws+ case-item* 'esac' + case-item <-- pattern ((compound-list separator)? case-sep ws* / error) + case-sep < ';;' + pattern <-- sp* word (sp* '|' sp* word)* sp* ')' sp* + + for-keyword < 'for' + for-clause <-- for-keyword sp+ name in-expression? sp* sequential-sep do-group + in-keyword < 'in' + in-expression <-- ws+ in-keyword expression? + expression <-- sp+ (substitution / word+) + do-keyword < 'do' + done-keyword < 'done' + do-group <-- do-keyword ws* compound-list separator done-keyword + + if-keyword < 'if' + fi-keyword < 'fi' + if-clause <-- if-keyword compound-list separator then-part elif-part* else-part? fi-keyword + then-keyword < 'then' + then-part <-- then-keyword ws* compound-list separator + elif-keyword < 'elif' + elif-part <-- elif-keyword compound-list separator then-keyword ws* compound-list separator else-part? + else-keyword < 'else' + else-part <-- else-keyword compound-list separator + + while-keyword < 'while' + while-clause <-- while-keyword compound-list separator do-group + + until-keyword < 'until' + until-clause <-- until-keyword compound-list separator do-group + filename <-- word name <-- identifier identifier <- [_a-zA-Z][_a-zA-Z0-9]* - word <-- test / substitution / assignment / number / literal + word <-- test / substitution / assignment / number / variable / delim / literal number <-- [0-9]+ test <-- ltest (!rtest .)* rtest ltest < '[ ' @@ -118,7 +143,7 @@ substitution <-- ('$(' script ')') / ('`' script '`') assignment <-- name assign (substitution / word)? assign < '=' - literal <-- (variable / delim / (![0-9] (![()] !io-op !sp !nl !break !pipe !assign !bt !sq !dq .)+) / ([0-9]+ &separator)) literal* + literal <-- (!pipe !semi !nl !sp .)+ variable <-- '$' ('$' / '*' / '?' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) delim <-- singlequotes / doublequotes / substitution sq < ['] @@ -128,18 +153,22 @@ doublequotes <-- dq (singlequotes / substitution / variable / (!dq .))* dq separator <- (sp* break ws*) / ws+ break <- amp / semi !semi - sequential-sep <-- (semi !semi ws*) / ws+ + sequential-sep <- (semi !semi ws*) / ws+ amp <- '&' semi < ';' nl < '\n' sp < [\t ] - ws < sp / nl") + ws < sp / nl + error <-- .*") (let* ((match (match-pattern script input)) (end (peg:end match)) - (tree (peg:tree match))) + (pt (peg:tree match))) (if (eq? (string-length input) end) - tree + (let* ((foo (pretty-print pt)) + (ast (transform (keyword-flatten '(pipeline) pt))) + (foo (pretty-print ast))) + ast) (if match (begin (format (current-error-port) "parse error: at offset: ~a\n" end) @@ -148,3 +177,15 @@ (begin (format (current-error-port) "parse error: no match\n") #f))))) + +(define (transform ast) + (match ast + (('script o ...) (map transform o)) + (('pipeline o ...) `(pipeline ,@(map transform o))) + (('command o ...) `(command ,@(map transform o))) + (('word o) (transform o)) + (('literal o) (transform o)) + (('name o) o) + (('number o) o) + (('assignment a b) `(assignment ,(transform a) ,(transform b))) + (_ ast))) From 7054858d9adb12d9d4d920d55623d88faa6aaba2 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Fri, 13 Jul 2018 21:42:50 +0200 Subject: [PATCH 112/312] checkpoint --- gash/peg.scm | 178 ++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 140 insertions(+), 38 deletions(-) diff --git a/gash/peg.scm b/gash/peg.scm index 42c7089..760f61e 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -1,11 +1,18 @@ (define-module (gash peg) + #:use-module (ice-9 ftw) + #:use-module (ice-9 local-eval) #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) #:use-module (ice-9 peg) #:use-module (ice-9 peg codegen) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (gash io) + #:use-module (gash util) + #:export (parse peg-trace?)) (define (wrap-parser-for-users for-syntax parser accumsym s-syn) @@ -52,15 +59,6 @@ (or (loop (car x)) (loop (cdr x))))))) -(define (parse input) - (let ((tree (parse- input))) - (cond ((error? tree) - (format (current-error-port) "error:\n") - (pretty-print tree (current-error-port)) - #f) - (#t - tree)))) - (define (parse- input) (define label "") (define (label-name str len pos) @@ -79,16 +77,21 @@ (define-peg-string-patterns "script <-- ws* (term (separator term)* separator?)? - term <- pipeline (sp* ('&&' / '||') ws* pipeline)* + term <- pipeline (sp* (and / or) ws* pipeline)* + and <-- '&&' + or <-- '||' pipe < '|' - pipeline <-- '!'? sp* command (sp* pipe ws* command)* + pipeline-head <- sp* command + pipeline-tail <- sp* pipe ws* command + negate <-- '!' + pipeline <-- negate? pipeline-head pipeline-tail* command <-- (compound-command (sp+ io-redirect)*) / simple-command / function-def - compound-command <- brace-group / subshell / for-clause / case-clause / if-clause / while-clause / until-clause + compound-command <- brace-group / subshell / for-clause / case-clause / if-clause / while-clause / until-clause simple-command <- (sp* (io-redirect sp+)* nonreserved)+ nonreserved <- &(reserved word) word / !reserved word reserved < 'case' / 'esac' / 'if' / 'fi' / 'then' / 'else' / 'elif' / 'for' / 'done' / 'do' / 'until' / 'while' - function-def <-- name sp* '(' sp* ')' ws* (function-body / error) + function-def <-- name sp* lpar sp* rpar ws* (function-body / error) function-body <-- compound-command io-redirect* io-redirect <-- [0-9]* sp* (io-here / io-file) @@ -98,7 +101,7 @@ io-suffix <- sp* here-label sp* nl brace-group <-- '{' (sp* (compound-list / error) sp* '}' / error) - subshell <-- '(' compound-list separator ')' + subshell <-- lpar compound-list separator rpar compound-list <- term (separator term)* case-keyword < 'case' @@ -108,44 +111,47 @@ pattern <-- sp* word (sp* '|' sp* word)* sp* ')' sp* for-keyword < 'for' - for-clause <-- for-keyword sp+ name in-expression? sp* sequential-sep do-group in-keyword < 'in' - in-expression <-- ws+ in-keyword expression? - expression <-- sp+ (substitution / word+) + for-clause <-- for-keyword sp+ name (ws+ in-keyword expression)? sp* sequential-sep do-group + expression <-- (sp+ word)+ do-keyword < 'do' done-keyword < 'done' - do-group <-- do-keyword ws* compound-list separator done-keyword + do-group <- do-keyword ws* compound-list separator done-keyword if-keyword < 'if' fi-keyword < 'fi' - if-clause <-- if-keyword compound-list separator then-part elif-part* else-part? fi-keyword + if-clause <-- if-keyword expression separator then-part elif-part* else-part? fi-keyword then-keyword < 'then' then-part <-- then-keyword ws* compound-list separator elif-keyword < 'elif' - elif-part <-- elif-keyword compound-list separator then-keyword ws* compound-list separator else-part? + elif-part <-- elif-keyword ws* compound-list separator then-keyword ws* compound-list separator else-part? else-keyword < 'else' - else-part <-- else-keyword compound-list separator + else-part <-- else-keyword ws* compound-list separator while-keyword < 'while' - while-clause <-- while-keyword compound-list separator do-group + while-clause <-- while-keyword ws* compound-list separator do-group until-keyword < 'until' - until-clause <-- until-keyword compound-list separator do-group + until-clause <-- until-keyword ws* compound-list separator do-group filename <-- word name <-- identifier identifier <- [_a-zA-Z][_a-zA-Z0-9]* - word <-- test / substitution / assignment / number / variable / delim / literal + word <- test / substitution / assignment / number / variable / delim / literal number <-- [0-9]+ - test <-- ltest (!rtest .)* rtest + test <-- ltest expression rtest ltest < '[ ' rtest < ' ]' - substitution <-- ('$(' script ')') / ('`' script '`') - assignment <-- name assign (substitution / word)? + lsubst < '$(' + rsubst < ')' + tick < '`' + substitution <-- lsubst script rsubst / tick script tick + assignment <-- name assign (substitution / word)* assign < '=' - literal <-- (!pipe !semi !nl !sp .)+ - variable <-- '$' ('$' / '*' / '?' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) - delim <-- singlequotes / doublequotes / substitution + dollar <- '$' + literal <-- (!'[' !']' !tick !dollar !pipe !semi !par !nl !sp .)+ + variable <-- dollar (dollar / '*' / '?' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) + delim <- singlequotes / doublequotes / substitution sq < ['] dq < [\"] bt < [`] @@ -156,6 +162,9 @@ sequential-sep <- (semi !semi ws*) / ws+ amp <- '&' semi < ';' + lpar < '(' + rpar < ')' + par < lpar / rpar nl < '\n' sp < [\t ] ws < sp / nl @@ -165,27 +174,120 @@ (end (peg:end match)) (pt (peg:tree match))) (if (eq? (string-length input) end) - (let* ((foo (pretty-print pt)) - (ast (transform (keyword-flatten '(pipeline) pt))) - (foo (pretty-print ast))) - ast) + pt (if match (begin (format (current-error-port) "parse error: at offset: ~a\n" end) - (pretty-print tree (current-error-port)) + (pretty-print pt (current-error-port)) #f) (begin (format (current-error-port) "parse error: no match\n") #f))))) +(define (parse input) + (let* ((pt (parse- input)) + (foo (pretty-print pt)) + (ast (transform (keyword-flatten '(pipeline) pt))) + (foo (pretty-print ast)) + ) + (cond ((error? ast) + (stderr "error:") (pretty-print ast (current-error-port)) #f) + (else + (map (cut local-eval <> (the-environment)) ast) + ast)))) + (define (transform ast) (match ast (('script o ...) (map transform o)) - (('pipeline o ...) `(pipeline ,@(map transform o))) + (('substitution o) `(substitution ,@(transform o))) + (('pipeline o) (pk `(pipeline ,(transform o)))) + (('pipeline h t) (pk `(pipeline ,(transform h) ,@(map transform t)))) (('command o ...) `(command ,@(map transform o))) - (('word o) (transform o)) (('literal o) (transform o)) (('name o) o) (('number o) o) - (('assignment a b) `(assignment ,(transform a) ,(transform b))) + (('expression o ...) `(expression ,@(map transform o))) + (('assignment a b) `(lambda _ (assignment ,(transform a) ,(transform b)))) + (('for-clause name expr do) `(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,(transform do)))) + (('if-clause expr then) `(if ,(transform expr) ,(transform then))) + (('if-clause expr then else) `(if ,(transform expr) ,(transform then) ,(transform else))) + (('then-part o ...) `(begin ,@(map transform o))) + (('else-part o ...) `(begin ,@(map transform o))) (_ ast))) + +(define global-variables (map (lambda (key-value) + (let* ((key-value (string-split key-value #\=)) + (key (car key-value)) + (value (cadr key-value))) + (cons key value))) + (environ))) + +(define (glob pattern) + (define (glob? pattern) + (and (string? pattern) (string-match "\\?|\\*" pattern))) + (define (glob2regex pattern) + (let* ((pattern (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post)) + (pattern (regexp-substitute/global #f "\\?" pattern 'pre "." 'post)) + (pattern (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post))) + (make-regexp (string-append "^" pattern "$")))) + (define (glob-match regex path) ;; pattern path -> bool + (regexp-match? (regexp-exec regex path))) + (define (glob- pattern paths) + (map (lambda (path) + (if (string-prefix? "./" path) (string-drop path 2) path)) + (append-map (lambda (path) + (map (cute string-append (if (string=? "/" path) "" path) "/" <>) + (filter (conjoin (negate (cut string-prefix? "." <>)) + (cute glob-match (glob2regex pattern) <>)) + (or (scandir path) '())))) + paths))) + (cond + ((not pattern) '("")) + ((glob? pattern) (let ((absolute? (string-prefix? "/" pattern))) + (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) + (paths (if absolute? '("/") '(".")))) + (if (null? patterns) + paths + (loop (cdr patterns) (glob- (car patterns) paths)))))) + (#t (list pattern)))) + +(define (singlequotes . o) + (string-join o "")) + +(define (doublequotes . o) + (string-join (append-map glob o) "")) + +(define (assignment name value) + (set! global-variables + (assoc-set! global-variables name value)) + #t) + +(define (variable name) + (or (assoc-ref global-variables (string-drop name 1)) "")) + +(define (expression . args) + (append-map glob args)) + +(define (for name expr body) + (for-each (lambda (value) + (assignment name value) + (body)) (pk 'for-expr: (expr)))) + +(define (command . args) + (define (exec command) + (cond ((procedure? command) command) + ((every string? command) + (cut apply (compose (cut equal? 0 <>) + (compose (cut assignment "?" <>) number->string) + status:exit-val + system*) command)) + (else (lambda () #t)))) + (exec (append-map glob args))) + +(define (substitution . commands) + (apply (@ (gash pipe) pipeline->string) (map cdr commands))) + +(define (pipeline . commands) + (apply (@ (gash pipe) pipeline) #t commands) + ;;(map (lambda (command) (command)) commands) + ) From f98637b8aaa8afbc2ebf89c8b7ac62c47ce773ad Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 08:29:51 +0200 Subject: [PATCH 113/312] oops, merge fix --- gash/gash.scm | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index 6887d30..2955900 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -394,10 +394,9 @@ mostly works, pipes work, some redirections work. (when (and (not (zero? status)) (shell-opt? "errexit")) (exit status)))) - (let ((ast (transform ast))) - (match ast - ('script #t) ;; skip - (_ (for-each exec ast))))) + (match ast + ('script #t) ;; skip + (_ (for-each exec ast)))) (define prompt (let* ((l (string #\001)) From 1174445a08652312807dbbc18e36dc7921b27f3a Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 08:51:12 +0200 Subject: [PATCH 114/312] more merge fu --- gash/gash.scm | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index 2955900..6b91daa 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -105,12 +105,15 @@ copyleft. (help? (option-ref options 'help #f)) (parse? (option-ref options 'parse #f)) (version? (option-ref options 'version #f)) - (files (option-ref options '() '()))) + (files (option-ref options '() '())) + (dead-run (compose sh-exec + (if #t (cut stdout "transformed: " <>) identity) (cut transform <>) + (if #t (cut stdout "parsed: " <>) identity)))) (set! %prefer-builtins? (option-ref options 'prefer-builtins #f)) (set-shell-opt! "errexit" (option-ref options 'errexit #f)) (set-shell-opt! "xtrace" (option-ref options 'xtrace #f)) - (if (option-ref options 'debug #f) - (set! %debug-level debug)) + (when (option-ref options 'debug #f) + (set! %debug-level debug)) (cond (help? (display-help)) (version? (display-version)) @@ -122,18 +125,22 @@ copyleft. ((pair? files) (let* ((asts (map file-to-ast files)) ;;(status (map pretty-print asts)) + ;;(status (map run asts)) ) + ;;(quit (or #t (every identity status))) + ;;(quit (every identity status)) (quit #t) )) (#t (let* ((HOME (string-append (getenv "HOME") "/.gash_history")) (thunk (lambda () (let loop ((line (readline (prompt)))) (when (not (eof-object? line)) - (let ((ast (string-to-ast line))) + (let* ((ast (string-to-ast line))) (when ast (if (not (string-null? line)) (add-history line)) + (stderr "hiero?\n") (run ast)) (loop (let ((previous (if ast "" (string-append line "\n"))) (next (readline (if ast (prompt) "> ")))) @@ -142,8 +149,8 @@ copyleft. (clear-history) (read-history HOME) (with-readline-completion-function completion thunk) - (write-history HOME)) - (newline))))))) + (write-history HOME) + (newline)))))))) (thunk))) (define (expand identifier o) ;;identifier-string -> symbol @@ -324,6 +331,7 @@ mostly works, pipes work, some redirections work. ;; transform ast -> list of expr ;; such that (map eval expr) (define (transform ast) + (format (current-error-port) "transform=~s\n" ast) (match ast (('script term "&") (list (background (transform term)))) (('script term) `(,(transform term))) From 20196ccaf0dc09e9f66afc1e8a9baea4edba3e92 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 09:08:20 +0200 Subject: [PATCH 115/312] further WIP: resurrect interactive mode --- gash/gash.scm | 32 +++++++++----------------------- 1 file changed, 9 insertions(+), 23 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index 6b91daa..75354c3 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -105,10 +105,7 @@ copyleft. (help? (option-ref options 'help #f)) (parse? (option-ref options 'parse #f)) (version? (option-ref options 'version #f)) - (files (option-ref options '() '())) - (dead-run (compose sh-exec - (if #t (cut stdout "transformed: " <>) identity) (cut transform <>) - (if #t (cut stdout "parsed: " <>) identity)))) + (files (option-ref options '() '()))) (set! %prefer-builtins? (option-ref options 'prefer-builtins #f)) (set-shell-opt! "errexit" (option-ref options 'errexit #f)) (set-shell-opt! "xtrace" (option-ref options 'xtrace #f)) @@ -118,30 +115,19 @@ copyleft. (help? (display-help)) (version? (display-version)) (command? (let ((ast (string-to-ast command?))) - (pretty-print ast) - (exit 0) - (exit (if ast (run ast) - 0)))) + (exit (assoc-ref global-variables "?")))) ((pair? files) (let* ((asts (map file-to-ast files)) - ;;(status (map pretty-print asts)) - ;;(status (map run asts)) - ) - - ;;(quit (or #t (every identity status))) - ;;(quit (every identity status)) - (quit #t) - )) + (status (assoc-ref global-variables "?"))) + (exit status))) (#t (let* ((HOME (string-append (getenv "HOME") "/.gash_history")) (thunk (lambda () (let loop ((line (readline (prompt)))) (when (not (eof-object? line)) (let* ((ast (string-to-ast line))) - (when ast - (if (not (string-null? line)) - (add-history line)) - (stderr "hiero?\n") - (run ast)) + (when (and ast + (not (string-null? line))) + (add-history line)) (loop (let ((previous (if ast "" (string-append line "\n"))) (next (readline (if ast (prompt) "> ")))) (if (eof-object? next) next @@ -330,7 +316,7 @@ mostly works, pipes work, some redirections work. ;; transform ast -> list of expr ;; such that (map eval expr) -(define (transform ast) +(define (DEAD-transform ast) (format (current-error-port) "transform=~s\n" ast) (match ast (('script term "&") (list (background (transform term)))) @@ -378,7 +364,7 @@ mostly works, pipes work, some redirections work. ((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...) (_ ast))) ;; done -(define (sh-exec ast) +(define (DEAD-sh-exec ast) (define (exec cmd) (when (> %debug-level 0) (format (current-error-port) "sh-exec:exec cmd=~s\n" cmd)) From ff985aa083f548c44f164c07e8f4b98117067b37 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 09:26:57 +0200 Subject: [PATCH 116/312] verder aangehaakt --- gash/gash.scm | 31 ++----------------------------- gash/peg.scm | 42 ++++++++++++++++++++++++++++++++++++++---- gash/pipe.scm | 2 +- 3 files changed, 41 insertions(+), 34 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index 75354c3..07173a4 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -77,7 +77,8 @@ copyleft. ")) -(define global-variables (list (cons "SHELLOPTS" ""))) +(define global-variables (list (cons "SHELLOPTS" "") + (cons "?" 0))) (define (main args) (map (lambda (key-value) @@ -364,34 +365,6 @@ mostly works, pipes work, some redirections work. ((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...) (_ ast))) ;; done -(define (DEAD-sh-exec ast) - (define (exec cmd) - (when (> %debug-level 0) - (format (current-error-port) "sh-exec:exec cmd=~s\n" cmd)) - (let* ((job (local-eval cmd (the-environment))) - (stati (cond ((job? job) (map status:exit-val (job-status job))) - ((boolean? job) (list (if job 0 1))) - ((number? job) (list job)) - (else (list 0)))) - (status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0) - (car stati))) - (pipestatus (string-append - "(" - (string-join - (map (lambda (s i) - (format #f "[~a]=\"~a\"" s i)) - stati - (iota (length stati)))) - ")"))) - (set! global-variables (assoc-set! global-variables "PIPESTATUS" pipestatus)) - (set! global-variables (assoc-set! global-variables "?" (number->string status))) - (when (and (not (zero? status)) - (shell-opt? "errexit")) - (exit status)))) - (match ast - ('script #t) ;; skip - (_ (for-each exec ast)))) - (define prompt (let* ((l (string #\001)) (r (string #\002)) diff --git a/gash/peg.scm b/gash/peg.scm index 760f61e..810c4dc 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -10,14 +10,16 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (gash gash) #:use-module (gash io) + #:use-module (gash job) #:use-module (gash util) #:export (parse peg-trace?)) (define (wrap-parser-for-users for-syntax parser accumsym s-syn) #`(lambda (str strlen pos) - (when (> (@ (gash gash) %debug-level) 0) + (when (> (@ (gash gash) %debug-level) 1) (format (current-error-port) "~a ~a : ~s\n" (make-string (- pos (or (string-rindex str #\newline 0 pos) 0)) #\space) '#,s-syn @@ -184,16 +186,48 @@ (format (current-error-port) "parse error: no match\n") #f))))) +(define (sh-exec ast) + (define (exec cmd) + (when (> %debug-level 0) + (format (current-error-port) "sh-exec:exec cmd=~s\n" cmd)) + (let* ((job (warn 'job (local-eval cmd (the-environment)))) + (stati (cond ((job? job) (map status:exit-val (warn 'job-status (job-status job)))) + ((boolean? job) (list (if job 0 1))) + ((number? job) (list job)) + (else (list 0)))) + (status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0) + (car stati))) + (pipestatus (string-append + "(" + (string-join + (map (lambda (s i) + (format #f "[~a]=\"~a\"" s i)) + stati + (iota (length stati)))) + ")"))) + (set! global-variables (assoc-set! global-variables "PIPESTATUS" pipestatus)) + (set! global-variables (assoc-set! global-variables "?" (number->string status))) + (when (and (not (zero? status)) + (shell-opt? "errexit")) + (exit status)))) + (when (> %debug-level 1) + (format (current-error-port) "sh-exec:exec ast=~s\n" ast)) + (match ast + ('script #t) ;; skip + (('pipeline command ...) (exec ast)) + (_ (for-each exec ast)))) + + (define (parse input) (let* ((pt (parse- input)) (foo (pretty-print pt)) (ast (transform (keyword-flatten '(pipeline) pt))) - (foo (pretty-print ast)) - ) + (foo (pretty-print ast))) (cond ((error? ast) (stderr "error:") (pretty-print ast (current-error-port)) #f) (else - (map (cut local-eval <> (the-environment)) ast) + (map sh-exec ast) + ;;(map (cut local-eval <> (the-environment)) ast) ast)))) (define (transform ast) diff --git a/gash/pipe.scm b/gash/pipe.scm index 5f18b88..a3e7976 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -100,7 +100,7 @@ (job (new-job)) (debug-id (job-debug-id job)) (commands - (if (zero? %debug-level) commands + (if (< %debug-level 3) commands (fold-right (lambda (command id lst) (let ((file (string-append debug-id "." id))) (cons* command `("tee" ,file) lst))) From 42fbcb942ae5679597a85631ec9a343b20326935 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 09:46:30 +0200 Subject: [PATCH 117/312] fix exit-status in `command' --- gash/peg.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/gash/peg.scm b/gash/peg.scm index 810c4dc..0592959 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -311,9 +311,13 @@ (define (exec command) (cond ((procedure? command) command) ((every string? command) - (cut apply (compose (cut equal? 0 <>) - (compose (cut assignment "?" <>) number->string) + (cut apply (compose (cut warn 'end-val <>) + (lambda (status) + ((compose (cut assignment "?" <>) number->string) status) + status) + (cut warn 'exit-val <>) status:exit-val + (cut warn 'status <>) system*) command)) (else (lambda () #t)))) (exec (append-map glob args))) From f3c8c2c7f0b482df4cad71458f6f642a875f6c4b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 10:20:05 +0200 Subject: [PATCH 118/312] exit-stati: WIP --- gash/gash.scm | 19 +++++-------------- gash/peg.scm | 49 +++++++++++++++++++++++++++++++------------------ gash/pipe.scm | 8 +++++--- 3 files changed, 41 insertions(+), 35 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index 07173a4..e9d78b2 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -77,16 +77,7 @@ copyleft. ")) -(define global-variables (list (cons "SHELLOPTS" "") - (cons "?" 0))) - (define (main args) - (map (lambda (key-value) - (let* ((key-value (string-split key-value #\=)) - (key (car key-value)) - (value (cadr key-value))) - (set! global-variables (assoc-set! global-variables key value)))) - (environ)) (let ((thunk (lambda () (job-control-init) @@ -116,10 +107,10 @@ copyleft. (help? (display-help)) (version? (display-version)) (command? (let ((ast (string-to-ast command?))) - (exit (assoc-ref global-variables "?")))) + (exit (assoc-ref %global-variables "?")))) ((pair? files) (let* ((asts (map file-to-ast files)) - (status (assoc-ref global-variables "?"))) + (status (assoc-ref %global-variables "?"))) (exit status))) (#t (let* ((HOME (string-append (getenv "HOME") "/.gash_history")) (thunk (lambda () @@ -255,16 +246,16 @@ mostly works, pipes work, some redirections work. (define cp-command (wrap-command cp-command-implementation "cp")) (define (set-shell-opt! name set?) - (let* ((shell-opts (assoc-ref global-variables "SHELLOPTS")) + (let* ((shell-opts (assoc-ref %global-variables "SHELLOPTS")) (options (if (string-null? shell-opts) '() (string-split shell-opts #\:))) (new-options (if set? (delete-duplicates (sort (cons name options) string<)) (filter (negate (cut equal? <> name)) options))) (new-shell-opts (string-join new-options ":"))) - (set! global-variables (assoc-set! global-variables "SHELLOPTS" new-shell-opts)))) + (assignment "SHELLOPTS" new-shell-opts))) (define (shell-opt? name) - (member name (string-split (assoc-ref global-variables "SHELLOPTS") #\:))) + (member name (string-split (assoc-ref %global-variables "SHELLOPTS") #\:))) (define %commands ;; Built-in commands. diff --git a/gash/peg.scm b/gash/peg.scm index 0592959..2498155 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -15,7 +15,12 @@ #:use-module (gash job) #:use-module (gash util) - #:export (parse peg-trace?)) + #:export ( + assignment + %global-variables + parse + peg-trace? + )) (define (wrap-parser-for-users for-syntax parser accumsym s-syn) #`(lambda (str strlen pos) @@ -190,8 +195,8 @@ (define (exec cmd) (when (> %debug-level 0) (format (current-error-port) "sh-exec:exec cmd=~s\n" cmd)) - (let* ((job (warn 'job (local-eval cmd (the-environment)))) - (stati (cond ((job? job) (map status:exit-val (warn 'job-status (job-status job)))) + (let* ((job (local-eval cmd (the-environment))) + (stati (cond ((job? job) (map status:exit-val (job-status job))) ((boolean? job) (list (if job 0 1))) ((number? job) (list job)) (else (list 0)))) @@ -205,11 +210,12 @@ stati (iota (length stati)))) ")"))) - (set! global-variables (assoc-set! global-variables "PIPESTATUS" pipestatus)) - (set! global-variables (assoc-set! global-variables "?" (number->string status))) + (assignment "PIPESTATUS" pipestatus) + (assignment "?" (number->string status)) (when (and (not (zero? status)) (shell-opt? "errexit")) - (exit status)))) + (exit status)) + status)) (when (> %debug-level 1) (format (current-error-port) "sh-exec:exec ast=~s\n" ast)) (match ast @@ -249,12 +255,18 @@ (('else-part o ...) `(begin ,@(map transform o))) (_ ast))) -(define global-variables (map (lambda (key-value) - (let* ((key-value (string-split key-value #\=)) - (key (car key-value)) - (value (cadr key-value))) - (cons key value))) - (environ))) +;; FIXME: export/env vs set +(define %global-variables + (map identity ;; FIXME: make mutable + `(("SHELLOPTS" . "") + ("PIPESTATUS" . "([0]=\"0\"") + ("?" . "") + ,@(map (lambda (key-value) + (let* ((key-value (string-split key-value #\=)) + (key (car key-value)) + (value (cadr key-value))) + (cons key value))) + (environ))))) (define (glob pattern) (define (glob? pattern) @@ -292,12 +304,12 @@ (string-join (append-map glob o) "")) (define (assignment name value) - (set! global-variables - (assoc-set! global-variables name value)) + (set! %global-variables + (assoc-set! %global-variables name value)) #t) (define (variable name) - (or (assoc-ref global-variables (string-drop name 1)) "")) + (or (assoc-ref %global-variables (string-drop name 1)) "")) (define (expression . args) (append-map glob args)) @@ -310,9 +322,10 @@ (define (command . args) (define (exec command) (cond ((procedure? command) command) + ((every string? command) (cut apply (compose status:exit-val system*) command)) + ;; not sure whether to do $?/PIPESTATUS here or in sh-exec ((every string? command) - (cut apply (compose (cut warn 'end-val <>) - (lambda (status) + (cut apply (compose (lambda (status) ((compose (cut assignment "?" <>) number->string) status) status) (cut warn 'exit-val <>) @@ -320,7 +333,7 @@ (cut warn 'status <>) system*) command)) (else (lambda () #t)))) - (exec (append-map glob args))) + (warn 'command=> (exec (append-map glob args)))) (define (substitution . commands) (apply (@ (gash pipe) pipeline->string) (map cdr commands))) diff --git a/gash/pipe.scm b/gash/pipe.scm index a3e7976..ed8cc15 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -73,9 +73,11 @@ (when (pair? w) (close-port (current-output-port)) (set-current-output-port (car w))) - (if (thunk? command) (command) - (command input w)) - (exit 0)) + (let ((status (warn 'spawn-status (if (thunk? command) (command) + (command input w))))) + (exit (cond ((number? status) status) + ((boolean? status) status) + (else 0))))) (begin (map dup->fdes w ofd) (map dup->fdes input ifd) From 4d3751f654187af88851c45479a31010efbd0d30 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 11:43:17 +0200 Subject: [PATCH 119/312] resurrect builtins: WIP --- build-aux/build-guile.sh | 1 + gash/builtins.scm | 116 ++++++++++++++++++++++++++++++++++++ gash/gash.scm | 125 ++------------------------------------- gash/peg.scm | 64 +++++++++++++++++--- gash/pipe.scm | 14 ++--- 5 files changed, 183 insertions(+), 137 deletions(-) create mode 100644 gash/builtins.scm diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 7c4f75a..d9fd178 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -37,6 +37,7 @@ set -e SCM_FILES=" gash/bournish-commands.scm +gash/builtins.scm gash/guix-build-utils.scm gash/gash.scm gash/io.scm diff --git a/gash/builtins.scm b/gash/builtins.scm new file mode 100644 index 0000000..988ba38 --- /dev/null +++ b/gash/builtins.scm @@ -0,0 +1,116 @@ +(define-module (gash builtins) + #:use-module (ice-9 match) + + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + + #:use-module (gash bournish-commands) + #:use-module (gash gash) + #:use-module (gash job) + #:use-module (gash peg) + + #:export ( + %builtin-commands + PATH-search-path + ;; cd-command + ;; ("bg" . ,bg-command) + ;; ("cat" . ,cat-command) + ;; ("cd" . ,cd-command) + ;; ("cp" . ,cp-command) + ;; ("echo" . ,echo-command) + ;; ("exit" . ,exit-command) + ;; ("fg" . ,fg-command) + ;; ("help" . ,help-command) + ;; ("jobs" . ,jobs-command) + ;; ("ls" . ,ls-command) + ;; ("pwd" . ,pwd-command) + ;; ("reboot" . ,reboot-command) + ;; ("rm" . ,rm-command) + ;; ("set" . ,set-command) + ;; ("wc" . ,wc-command) + ;; ("which" . ,which-command) + +)) + +(define (PATH-search-path program) + (search-path (string-split (getenv "PATH") #\:) program)) + +(define (cd-command . args) + (match args + (() (chdir (getenv "HOME"))) + ((dir) + (chdir dir)) + ((args ...) + (format (current-error-port) "cd: too many arguments: ~a\n" (string-join args))))) + +(define (echo-command . args) + (match args + (() (newline)) + (("-n" args ...) (map display args)) + (_ (map display args) (newline)))) + +(define (bg-command . args) + (match args + (() (bg 1)) + ((job x ...) (bg (string->number (car job)))))) + +(define (fg-command . args) + (match args + (() (fg 1)) + ((job x ...) (fg (string->number (car job)))))) + +(define pwd-command (lambda _ (stdout (getcwd)))) + +(define (set-command . args) ;; TODO export; env vs set + (define (display-var o) + (format #t "~a=~a\n" (car o) (cdr o))) + (match args + (() (for-each display-var global-variables)) + (("-e") (set-shell-opt! "errexit" #t)) + (("+e") (set-shell-opt! "errexit" #f)) + (("-x") (set-shell-opt! "xtrace" #t)) + (("+x") (set-shell-opt! "xtrace" #f)))) + +(define (exit-command . args) + (match args + (() (exit 0)) + ((status) + (exit (string->number status))) + ((args ...) + (format (current-error-port) "exit: too many arguments: ~a\n" (string-join args))))) + +(define (help-command . _) + (display "\ +Hello, this is gash, Guile As SHell. + +Gash is work in progress; many language constructs work, globbing +mostly works, pipes work, some redirections work. +") + (when (or %prefer-builtins? (not (PATH-search-path "ls"))) + (display "\nIt features the following, somewhat naive builtin commands\n") + (display-tabulated (map car %commands)))) + +(define (cp-command-implementation source dest . rest) + (copy-file source dest)) + +(define cp-command (wrap-command cp-command-implementation "cp")) + +(define %builtin-commands + `( + ("bg" . ,bg-command) + ("cat" . ,cat-command) + ("cd" . ,cd-command) + ("cp" . ,cp-command) + ;;("echo" . ,echo-command) BROKEN wrt variables for now + ("exit" . ,exit-command) + ("fg" . ,fg-command) + ("help" . ,help-command) + ("jobs" . ,jobs-command) + ("ls" . ,ls-command) + ("pwd" . ,pwd-command) + ("reboot" . ,reboot-command) + ("rm" . ,rm-command) + ("set" . ,set-command) + ("wc" . ,wc-command) + ("which" . ,which-command) + )) diff --git a/gash/gash.scm b/gash/gash.scm index e9d78b2..3c8513e 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -19,13 +19,14 @@ #:use-module (gash peg) #:use-module (gash io) #:use-module (gash util) - #:use-module (gash bournish-commands) #:export (main %debug-level + %prefer-builtins? shell-opt?)) -(define %debug-level 0) +(define %debug-level 0) ; 1 informational, 2 verbose, 3 peg tracing +(define %prefer-builtins? #f) ; use builtin, even if COMMAND is available in PATH? (define (remove-shell-comments s) (string-join (map @@ -177,132 +178,14 @@ copyleft. (loop (cdr patterns) (glob- (car patterns) paths)))))) (#t (list pattern)))) -(define (background ast) +(define (DEAD-background ast) (match ast (('pipeline fg rest ...) `(pipeline #f ,@rest)) (_ ast))) -(define (PATH-search-path program) - (search-path (string-split (getenv "PATH") #\:) program)) - -(define (cd-command . args) - (match args - (() (chdir (getenv "HOME"))) - ((dir) - (chdir dir)) - ((args ...) - (format (current-error-port) "cd: too many arguments: ~a\n" (string-join args))))) - -(define (echo-command . args) - (match args - (() (newline)) - (("-n" args ...) (map display args)) - (_ (map display args) (newline)))) - -(define (bg-command . args) - (match args - (() (bg 1)) - ((job x ...) (bg (string->number (car job)))))) - -(define (fg-command . args) - (match args - (() (fg 1)) - ((job x ...) (fg (string->number (car job)))))) - -(define pwd-command (lambda _ (stdout (getcwd)))) - -(define (set-command . args) ;; TODO export; env vs set - (define (display-var o) - (format #t "~a=~a\n" (car o) (cdr o))) - (match args - (() (for-each display-var global-variables)) - (("-e") (set-shell-opt! "errexit" #t)) - (("+e") (set-shell-opt! "errexit" #f)) - (("-x") (set-shell-opt! "xtrace" #t)) - (("+x") (set-shell-opt! "xtrace" #f)))) - -(define (exit-command . args) - (match args - (() (exit 0)) - ((status) - (exit (string->number status))) - ((args ...) - (format (current-error-port) "exit: too many arguments: ~a\n" (string-join args))))) - -(define (help-command . _) - (display "\ -Hello, this is gash, Guile As SHell. - -Gash is work in progress; many language constructs work, globbing -mostly works, pipes work, some redirections work. -") - (when (or %prefer-builtins? (not (PATH-search-path "ls"))) - (display "\nIt features the following, somewhat naive builtin commands\n") - (display-tabulated (map car %commands)))) - -(define (cp-command-implementation source dest . rest) - (copy-file source dest)) - -(define cp-command (wrap-command cp-command-implementation "cp")) - -(define (set-shell-opt! name set?) - (let* ((shell-opts (assoc-ref %global-variables "SHELLOPTS")) - (options (if (string-null? shell-opts) '() - (string-split shell-opts #\:))) - (new-options (if set? (delete-duplicates (sort (cons name options) string<)) - (filter (negate (cut equal? <> name)) options))) - (new-shell-opts (string-join new-options ":"))) - (assignment "SHELLOPTS" new-shell-opts))) - (define (shell-opt? name) (member name (string-split (assoc-ref %global-variables "SHELLOPTS") #\:))) -(define %commands - ;; Built-in commands. - `( - ("bg" . ,bg-command) - ("cat" . ,cat-command) - ("cd" . ,cd-command) - ("cp" . ,cp-command) - ("echo" . ,echo-command) - ("exit" . ,exit-command) - ("fg" . ,fg-command) - ("help" . ,help-command) - ("jobs" . ,jobs-command) - ("ls" . ,ls-command) - ("pwd" . ,pwd-command) - ("reboot" . ,reboot-command) - ("rm" . ,rm-command) - ("set" . ,set-command) - ("wc" . ,wc-command) - ("which" . ,which-command) - )) - -(define %prefer-builtins? #t) ; use builtin, even if COMMAND is available in PATH? -(define (builtin ast) - (receive (command args) - (match ast - ((('append ('glob command) args ...)) (values command args)) - ((('glob command)) (values command #f)) - (_ (values #f #f))) - (let ((program (and command (PATH-search-path command)))) - (when (> %debug-level 0) - (format (current-error-port) "command ~a => ~s ~s\n" program command args)) - (cond ((and program (not %prefer-builtins?)) - #f) - ((and command (assoc-ref %commands command)) - => - (lambda (command) - (if args - `(,apply ,command ,@args) - `(,command)))) - (else - (match ast - (('for-each rest ...) ast) - (('if rest ...) ast) - (#t #t) - (_ #f))))))) - (define (tostring . args) (with-output-to-string (cut map display args))) diff --git a/gash/peg.scm b/gash/peg.scm index 2498155..dad53c4 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -5,11 +5,13 @@ #:use-module (ice-9 pretty-print) #:use-module (ice-9 peg) #:use-module (ice-9 peg codegen) + #:use-module (ice-9 receive) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (gash builtins) #:use-module (gash gash) #:use-module (gash io) #:use-module (gash job) @@ -20,6 +22,7 @@ %global-variables parse peg-trace? + set-shell-opt! )) (define (wrap-parser-for-users for-syntax parser accumsym s-syn) @@ -220,7 +223,16 @@ (format (current-error-port) "sh-exec:exec ast=~s\n" ast)) (match ast ('script #t) ;; skip - (('pipeline command ...) (exec ast)) + (('pipeline commands ...) + (when (shell-opt? "xtrace") + (for-each + (lambda (o) + (match o + (('command command ...) + (format (current-error-port) "+ ~a\n" (string-join command))) + (_ (format (current-error-port) "FIXME trace:~s" o)))) + (reverse commands))) + (exec ast)) (_ (for-each exec ast)))) @@ -237,10 +249,12 @@ ast)))) (define (transform ast) + (when (> %debug-level 1) + (format (current-error-port) "transform ast=~s\n" ast)) (match ast (('script o ...) (map transform o)) (('substitution o) `(substitution ,@(transform o))) - (('pipeline o) (pk `(pipeline ,(transform o)))) + (('pipeline o) (pk `(pipeline ,(let ((c (warn 'transform (transform o)))) (or (builtin c) c))))) (('pipeline h t) (pk `(pipeline ,(transform h) ,@(map transform t)))) (('command o ...) `(command ,@(map transform o))) (('literal o) (transform o)) @@ -255,12 +269,46 @@ (('else-part o ...) `(begin ,@(map transform o))) (_ ast))) +(define (set-shell-opt! name set?) + (let* ((shell-opts (assoc-ref %global-variables "SHELLOPTS")) + (options (if (string-null? shell-opts) '() + (string-split shell-opts #\:))) + (new-options (if set? (delete-duplicates (sort (cons name options) string<)) + (filter (negate (cut equal? <> name)) options))) + (new-shell-opts (string-join new-options ":"))) + ;; HMM + (assignment "SHELLOPTS" new-shell-opts) + (lambda _ (format (current-error-port) "hiero\n") "daro") + '("hiero2"))) + +(define (builtin ast) + (when (> %debug-level 0) + (format (current-error-port) "builtin ast=~s\n" ast)) + (receive (command args) + (match ast + (('command (and (? string?) command) args ...) (values command args)) + ;; ((('append ('glob command) args ...)) (values command args)) + ;; ((('glob command)) (values command #f)) + (_ (values #f #f))) + (let ((program (and command (PATH-search-path command)))) + (when (> %debug-level 0) + (format (current-error-port) "command ~a => ~s ~s\n" program command args)) + (cond ((and program (not %prefer-builtins?)) + #f) + ((and command (assoc-ref %builtin-commands command)) + => + (lambda (command) + (if args + `(,apply ,command ',args) + command))) + (else #f))))) + ;; FIXME: export/env vs set (define %global-variables (map identity ;; FIXME: make mutable - `(("SHELLOPTS" . "") - ("PIPESTATUS" . "([0]=\"0\"") - ("?" . "") + `(,(cons "SHELLOPTS" "") + ,(cons "PIPESTATUS" "([0]=\"0\"") + ,(cons "?" "") ,@(map (lambda (key-value) (let* ((key-value (string-split key-value #\=)) (key (car key-value)) @@ -333,12 +381,10 @@ (cut warn 'status <>) system*) command)) (else (lambda () #t)))) - (warn 'command=> (exec (append-map glob args)))) + (exec (append-map glob args))) (define (substitution . commands) (apply (@ (gash pipe) pipeline->string) (map cdr commands))) (define (pipeline . commands) - (apply (@ (gash pipe) pipeline) #t commands) - ;;(map (lambda (command) (command)) commands) - ) + (apply (@ (gash pipe) pipeline) #t commands)) diff --git a/gash/pipe.scm b/gash/pipe.scm index ed8cc15..bf9789c 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -73,8 +73,8 @@ (when (pair? w) (close-port (current-output-port)) (set-current-output-port (car w))) - (let ((status (warn 'spawn-status (if (thunk? command) (command) - (command input w))))) + (let ((status (if (thunk? command) (command) + (command input w)))) (exit (cond ((number? status) status) ((boolean? status) status) (else 0))))) @@ -90,11 +90,11 @@ (define (pipeline fg? . commands) (when (> %debug-level 0) (format (current-error-port) "pipeline[~a]: COMMANDS: ~s\n" fg? commands)) - (when (shell-opt? "xtrace") - (for-each - (lambda (o) - (format (current-error-port) "+ ~a\n" (string-join o))) - (reverse commands))) + ;; (when (shell-opt? "xtrace") + ;; (for-each + ;; (lambda (o) + ;; (format (current-error-port) "+ ~a\n" (string-join o))) + ;; (reverse commands))) (receive (r w) (pipe*) (move->fdes w 2) From f5339a09f5710bc71fbfb51af9db1c3a8aec1ccb Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sat, 14 Jul 2018 12:34:42 +0200 Subject: [PATCH 120/312] WIP: marginal --- TODO | 1 + gash/gash.scm | 1 + gash/peg.scm | 8 ++++---- test/substitution.sh | 2 +- 4 files changed, 7 insertions(+), 5 deletions(-) diff --git a/TODO b/TODO index 674e9ea..9211b2f 100644 --- a/TODO +++ b/TODO @@ -9,5 +9,6 @@ * compound: case, while, until * expansion: done * alias: +* iohere: * redirection: * posix compliance: diff --git a/gash/gash.scm b/gash/gash.scm index 3c8513e..3aedf3d 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -45,6 +45,7 @@ "" (string-split s #\newline))) (define (file-to-string filename) + (stdout "\n\n** " filename ":") ((compose read-string open-input-file) filename)) (define (string-to-ast string) diff --git a/gash/peg.scm b/gash/peg.scm index dad53c4..6ec18ba 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -159,7 +159,7 @@ assignment <-- name assign (substitution / word)* assign < '=' dollar <- '$' - literal <-- (!'[' !']' !tick !dollar !pipe !semi !par !nl !sp .)+ + literal <-- (!ltest !tick !dollar !pipe !semi !par !nl !sp .)+ variable <-- dollar (dollar / '*' / '?' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) delim <- singlequotes / doublequotes / substitution sq < ['] @@ -167,8 +167,8 @@ bt < [`] singlequotes <-- sq (doublequotes / (!sq .))* sq doublequotes <-- dq (singlequotes / substitution / variable / (!dq .))* dq - separator <- (sp* break ws*) / ws+ break <- amp / semi !semi + separator <- (sp* break ws*) / ws+ sequential-sep <- (semi !semi ws*) / ws+ amp <- '&' semi < ';' @@ -365,7 +365,7 @@ (define (for name expr body) (for-each (lambda (value) (assignment name value) - (body)) (pk 'for-expr: (expr)))) + (body)) (expr))) (define (command . args) (define (exec command) @@ -384,7 +384,7 @@ (exec (append-map glob args))) (define (substitution . commands) - (apply (@ (gash pipe) pipeline->string) (map cdr commands))) + (apply (@ (gash pipe) pipeline->string) (map cdr commands))) ;;HACK (define (pipeline . commands) (apply (@ (gash pipe) pipeline) #t commands)) diff --git a/test/substitution.sh b/test/substitution.sh index 2b87ce6..8d686de 100644 --- a/test/substitution.sh +++ b/test/substitution.sh @@ -1,2 +1,2 @@ echo $(find test -type f) -echo `find test -type f` +#echo `find test -type f` From c8960150684fbd4557d5ba9447a4ce93f330b720 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 13:32:04 +0200 Subject: [PATCH 121/312] resurrect builtins: WIP --- gash/builtins.scm | 30 ++++++++++-------------------- gash/peg.scm | 28 ++++++++++++++++++++-------- gash/pipe.scm | 2 +- 3 files changed, 31 insertions(+), 29 deletions(-) diff --git a/gash/builtins.scm b/gash/builtins.scm index 988ba38..8405576 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -12,25 +12,15 @@ #:export ( %builtin-commands PATH-search-path - ;; cd-command - ;; ("bg" . ,bg-command) - ;; ("cat" . ,cat-command) - ;; ("cd" . ,cd-command) - ;; ("cp" . ,cp-command) - ;; ("echo" . ,echo-command) - ;; ("exit" . ,exit-command) - ;; ("fg" . ,fg-command) - ;; ("help" . ,help-command) - ;; ("jobs" . ,jobs-command) - ;; ("ls" . ,ls-command) - ;; ("pwd" . ,pwd-command) - ;; ("reboot" . ,reboot-command) - ;; ("rm" . ,rm-command) - ;; ("set" . ,set-command) - ;; ("wc" . ,wc-command) - ;; ("which" . ,which-command) - -)) + bg-command + cd-command + echo-command + exit-command + fg-command + help-command + pwd-command + set-command + )) (define (PATH-search-path program) (search-path (string-split (getenv "PATH") #\:) program)) @@ -101,7 +91,7 @@ mostly works, pipes work, some redirections work. ("cat" . ,cat-command) ("cd" . ,cd-command) ("cp" . ,cp-command) - ;;("echo" . ,echo-command) BROKEN wrt variables for now + ("echo" . ,echo-command) BROKEN wrt variables for now ("exit" . ,exit-command) ("fg" . ,fg-command) ("help" . ,help-command) diff --git a/gash/peg.scm b/gash/peg.scm index 6ec18ba..49bcdb9 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -229,7 +229,11 @@ (lambda (o) (match o (('command command ...) - (format (current-error-port) "+ ~a\n" (string-join command))) + ;;(format (current-error-port) "+ ~a\n" (string-join command)) + ;; FIXME: side-effects done twice?! + ;; '(variable "$?"): not a string...hmm + (format (current-error-port) "+ ~a\n" (string-join (map (cut local-eval <> (the-environment)) command))) + ) (_ (format (current-error-port) "FIXME trace:~s" o)))) (reverse commands))) (exec ast)) @@ -248,6 +252,9 @@ ;;(map (cut local-eval <> (the-environment)) ast) ast)))) +(define (unspecified? o) + (eq? o *unspecified*)) + (define (transform ast) (when (> %debug-level 1) (format (current-error-port) "transform ast=~s\n" ast)) @@ -276,10 +283,7 @@ (new-options (if set? (delete-duplicates (sort (cons name options) string<)) (filter (negate (cut equal? <> name)) options))) (new-shell-opts (string-join new-options ":"))) - ;; HMM - (assignment "SHELLOPTS" new-shell-opts) - (lambda _ (format (current-error-port) "hiero\n") "daro") - '("hiero2"))) + (assignment "SHELLOPTS" new-shell-opts))) (define (builtin ast) (when (> %debug-level 0) @@ -299,7 +303,7 @@ => (lambda (command) (if args - `(,apply ,command ',args) + `(,apply ,command ',(map (cut local-eval <> (the-environment)) args)) command))) (else #f))))) @@ -308,7 +312,7 @@ (map identity ;; FIXME: make mutable `(,(cons "SHELLOPTS" "") ,(cons "PIPESTATUS" "([0]=\"0\"") - ,(cons "?" "") + ,(cons "?" "0") ,@(map (lambda (key-value) (let* ((key-value (string-split key-value #\=)) (key (car key-value)) @@ -387,4 +391,12 @@ (apply (@ (gash pipe) pipeline->string) (map cdr commands))) ;;HACK (define (pipeline . commands) - (apply (@ (gash pipe) pipeline) #t commands)) + (when (> %debug-level 1) + (format (current-error-port) "pijp: commands=~s\n" commands)) + ;; FIXME: after running a builtin, we still end up here with the builtin's result + ;; that should probably not happen, however, cater for it here for now + (match commands + (((and (? boolean?) boolean)) (if boolean 0 1)) + (((and (? number?) number)) number) + (((? unspecified?)) 0) + (_ (apply (@ (gash pipe) pipeline) #t commands)))) diff --git a/gash/pipe.scm b/gash/pipe.scm index bf9789c..aaba6e9 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -76,7 +76,7 @@ (let ((status (if (thunk? command) (command) (command input w)))) (exit (cond ((number? status) status) - ((boolean? status) status) + ((boolean? status) (if status 0 1)) (else 0))))) (begin (map dup->fdes w ofd) From 512b848b112e18ea0a666f7b41a651b5fbccb333 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 14:38:00 +0200 Subject: [PATCH 122/312] build: Add config.scm.in. * gash/config.scm.in: * configure: Use it to generate gash/config.scm * .gitignore: Ignore generated file. * gash/gash.scm (display-version): Use it. * build-aux/build-guile.sh: Compile it. --- .gitignore | 1 + build-aux/build-guile.sh | 1 + configure | 4 ++++ gash/config.scm.in | 30 ++++++++++++++++++++++++++++++ 4 files changed, 36 insertions(+) create mode 100644 gash/config.scm.in diff --git a/.gitignore b/.gitignore index eb10f8d..197644b 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,4 @@ /bin/gash /.config.make /doc/version.texi +/gash/config.scm diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index d9fd178..d0aa4c2 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -38,6 +38,7 @@ set -e SCM_FILES=" gash/bournish-commands.scm gash/builtins.scm +gash/config.scm gash/guix-build-utils.scm gash/gash.scm gash/io.scm diff --git a/configure b/configure index 261e62a..f23d4ca 100755 --- a/configure +++ b/configure @@ -40,6 +40,10 @@ SHELL=$BASH VERSION=$VERSION EOF +sed \ + -e "s,@VERSION@,$VERSION,"\ + gash/config.scm.in > gash/config.scm + cat < +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +(define-module (gash config) + #:export (%version)) + +;;; Commentary: +;;; +;;; Compile-time configuration of gash. When adding a substitution variable +;;; here, make sure to have configure substitute it. +;;; +;;; Code: + +(define %version + "@VERSION@") From 40aa82fca93b1027ad9fba8d8cbef6bde99cbbe5 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 14:38:52 +0200 Subject: [PATCH 123/312] builtins: ls: Support -a,--all,-1,--one-file-per-line,-h,--version. * gash/bournish-commands.scm (ls-command-implementation): Support -a,--all,-1,--one-file-per-line,-h,--version. --- gash/bournish-commands.scm | 93 ++++++++++++++++++++++++++------------ gash/builtins.scm | 19 ++++++++ gash/gash.scm | 7 +-- 3 files changed, 88 insertions(+), 31 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 34ac531..fc3d3b4 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -20,13 +20,18 @@ ;;; along with Gash. If not, see . (define-module (gash bournish-commands) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 match) #:use-module (ice-9 ftw) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (gash guix-build-utils) + #:use-module (gash config) #:use-module (gash io) #:export ( display-tabulated @@ -94,37 +99,69 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." (newline) (loop (map 1+ indexes))))) +(cond-expand + (guile + ;; Support -1, see https://lists.gnu.org/archive/html/bug-guile/2018-07/msg00009.html + (module-define! (resolve-module '(ice-9 getopt-long)) 'short-opt-rx (make-regexp "^-([a-zA-Z0-9]+)(.*)"))) + (else)) + (define ls-command-implementation ;; Run-time support procedure. (case-lambda (() (display-tabulated (scandir "."))) - (files - (let ((files (append-map (lambda (file) - (catch 'system-error - (lambda () - (match (stat:type (lstat file)) - ('directory - ;; Like GNU ls, list the contents of - ;; FILE rather than FILE itself. - (match (scandir file - (match-lambda - ((or "." "..") #f) - (_ #t))) - (#f - (list file)) - ((files ...) - (map (cut string-append file "/" <>) - files)))) - (_ - (list file)))) - (lambda args - (let ((errno (system-error-errno args))) - (format (current-error-port) "~a: ~a~%" - file (strerror errno)) - '())))) - files))) - (display-tabulated files))))) + (args + (format (current-error-port) "hiero:args=~s\n" args) + (let* ((option-spec + '((all (single-char #\a)) + (help) + (one-file-per-line (single-char #\1)) + (version))) + (options (getopt-long (cons "ls" args) option-spec)) + (all? (option-ref options 'all #f)) + (help? (option-ref options 'help #f)) + (one-file-per-line? (option-ref options 'one-file-per-line #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (cond (help? (display "Usage: ls [OPTION]... [FILE]... + +Options: + -a, --all do not ignore entries starting with . + -1 list one file per line + --help display this help and exit + --version display version information and exit +")) + (version? (format #t "ls (GASH) ~a\n" %version)) + (else + (let* ((files (if (null? files) (scandir ".") + (append-map (lambda (file) + (catch 'system-error + (lambda () + (match (stat:type (lstat file)) + ('directory + ;; Like GNU ls, list the contents of + ;; FILE rather than FILE itself. + (match (scandir file + (match-lambda + ((or "." "..") #f) + (_ #t))) + (#f + (list file)) + ((files ...) + (map (cut string-append file "/" <>) + files)))) + (_ + (list file)))) + (lambda args + (let ((errno (system-error-errno args))) + (format (current-error-port) "~a: ~a~%" + file (strerror errno)) + '())))) + files))) + (files (if all? files + (filter (negate (cut string-prefix? "." <>)) files)))) + (if one-file-per-line? (for-each stdout files) + (display-tabulated files))))))))) (define ls-command (wrap-command ls-command-implementation "ls")) diff --git a/gash/builtins.scm b/gash/builtins.scm index 8405576..c1832fb 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -1,3 +1,21 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + (define-module (gash builtins) #:use-module (ice-9 match) @@ -5,6 +23,7 @@ #:use-module (srfi srfi-26) #:use-module (gash bournish-commands) + #:use-module (gash config) #:use-module (gash gash) #:use-module (gash job) #:use-module (gash peg) diff --git a/gash/gash.scm b/gash/gash.scm index 3aedf3d..1c49c89 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -14,6 +14,7 @@ #:use-module (ice-9 receive) #:use-module (ice-9 regex) + #:use-module (gash config) #:use-module (gash job) #:use-module (gash pipe) #:use-module (gash peg) @@ -68,8 +69,8 @@ gash [options] ")) (define (display-version) - (display " -GASH 0.1 + (display (string-append " +GASH " %version " Copryright (C) 2016,2017,2018 R.E.W. van Beusekom, rutger.van.beusekom@gmail.com. @@ -77,7 +78,7 @@ This is gash, Guile As SHell. Gash is free software and is covered by the GNU General Public License version 3 or later, see COPYING for the copyleft. -")) +"))) (define (main args) (let ((thunk From 3ea368ab2f641a42b235517f4e28809125fb280a Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 14:50:41 +0200 Subject: [PATCH 124/312] resurrect help WIP --- gash/builtins.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/gash/builtins.scm b/gash/builtins.scm index c1832fb..b9c77c1 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -90,14 +90,14 @@ (define (help-command . _) (display "\ -Hello, this is gash, Guile As SHell. +Hello, this is GASH, Guile As SHell. -Gash is work in progress; many language constructs work, globbing +GASH is work in progress; many language constructs work, globbing mostly works, pipes work, some redirections work. ") (when (or %prefer-builtins? (not (PATH-search-path "ls"))) (display "\nIt features the following, somewhat naive builtin commands\n") - (display-tabulated (map car %commands)))) + (display-tabulated (map car %builtin-commands)))) (define (cp-command-implementation source dest . rest) (copy-file source dest)) @@ -110,7 +110,7 @@ mostly works, pipes work, some redirections work. ("cat" . ,cat-command) ("cd" . ,cd-command) ("cp" . ,cp-command) - ("echo" . ,echo-command) BROKEN wrt variables for now + ("echo" . ,echo-command) ("exit" . ,exit-command) ("fg" . ,fg-command) ("help" . ,help-command) From 23a13b08900f374cb34ee3a831e54edaf5454f4a Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 14:52:18 +0200 Subject: [PATCH 125/312] builtins: resurrect pwd WIP --- gash/builtins.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/gash/builtins.scm b/gash/builtins.scm index b9c77c1..0b1e315 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -26,6 +26,7 @@ #:use-module (gash config) #:use-module (gash gash) #:use-module (gash job) + #:use-module (gash io) #:use-module (gash peg) #:export ( From 56a36baee5d9071e1f2a399f3b92533af1b9d22f Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 15:06:18 +0200 Subject: [PATCH 126/312] factor-out environment. * gash/environment.scm: New file. * build-aux/build-guile.sh (SCM_FILES): Add it. * gash/peg.scm: Include it. (assignment, %global-variables, set-shell-opt!, variable): Remove. --- build-aux/build-guile.sh | 1 + gash/builtins.scm | 3 ++- gash/environment.scm | 58 ++++++++++++++++++++++++++++++++++++++++ gash/gash.scm | 3 ++- gash/peg.scm | 34 +---------------------- 5 files changed, 64 insertions(+), 35 deletions(-) create mode 100644 gash/environment.scm diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index d0aa4c2..5748985 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -39,6 +39,7 @@ SCM_FILES=" gash/bournish-commands.scm gash/builtins.scm gash/config.scm +gash/environment.scm gash/guix-build-utils.scm gash/gash.scm gash/io.scm diff --git a/gash/builtins.scm b/gash/builtins.scm index 0b1e315..e4c0286 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -24,10 +24,11 @@ #:use-module (gash bournish-commands) #:use-module (gash config) + #:use-module (gash environment) #:use-module (gash gash) #:use-module (gash job) #:use-module (gash io) - #:use-module (gash peg) + ;;#:use-module (gash peg) #:export ( %builtin-commands diff --git a/gash/environment.scm b/gash/environment.scm new file mode 100644 index 0000000..f1a32e7 --- /dev/null +++ b/gash/environment.scm @@ -0,0 +1,58 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 R.E.W. van Beusekom +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +(define-module (gash environment) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export ( + %global-variables + assignment + set-shell-opt! + variable + )) + +;; FIXME: export/env vs set +(define %global-variables + (map identity ;; FIXME: make mutable + `(,(cons "SHELLOPTS" "") + ,(cons "PIPESTATUS" "([0]=\"0\"") + ,(cons "?" "0") + ,@(map (lambda (key-value) + (let* ((key-value (string-split key-value #\=)) + (key (car key-value)) + (value (cadr key-value))) + (cons key value))) + (environ))))) + +(define (assignment name value) + (set! %global-variables + (assoc-set! %global-variables name value)) + #t) + +(define (variable name) + (or (assoc-ref %global-variables (string-drop name 1)) "")) + +(define (set-shell-opt! name set?) + (let* ((shell-opts (variable "SHELLOPTS")) + (options (if (string-null? shell-opts) '() + (string-split shell-opts #\:))) + (new-options (if set? (delete-duplicates (sort (cons name options) string<)) + (filter (negate (cut equal? <> name)) options))) + (new-shell-opts (string-join new-options ":"))) + (assignment "SHELLOPTS" new-shell-opts))) diff --git a/gash/gash.scm b/gash/gash.scm index 1c49c89..f85567c 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -15,6 +15,7 @@ #:use-module (ice-9 regex) #:use-module (gash config) + #:use-module (gash environment) #:use-module (gash job) #:use-module (gash pipe) #:use-module (gash peg) @@ -72,7 +73,7 @@ gash [options] (display (string-append " GASH " %version " -Copryright (C) 2016,2017,2018 R.E.W. van Beusekom, rutger.van.beusekom@gmail.com. +Copryright (C) 2016,2017,2018 R.E.W. van Beusekom This is gash, Guile As SHell. Gash is free software and is covered by the GNU General Public License version 3 or later, see COPYING for the diff --git a/gash/peg.scm b/gash/peg.scm index 49bcdb9..4eec087 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -12,17 +12,15 @@ #:use-module (srfi srfi-26) #:use-module (gash builtins) + #:use-module (gash environment) #:use-module (gash gash) #:use-module (gash io) #:use-module (gash job) #:use-module (gash util) #:export ( - assignment - %global-variables parse peg-trace? - set-shell-opt! )) (define (wrap-parser-for-users for-syntax parser accumsym s-syn) @@ -276,15 +274,6 @@ (('else-part o ...) `(begin ,@(map transform o))) (_ ast))) -(define (set-shell-opt! name set?) - (let* ((shell-opts (assoc-ref %global-variables "SHELLOPTS")) - (options (if (string-null? shell-opts) '() - (string-split shell-opts #\:))) - (new-options (if set? (delete-duplicates (sort (cons name options) string<)) - (filter (negate (cut equal? <> name)) options))) - (new-shell-opts (string-join new-options ":"))) - (assignment "SHELLOPTS" new-shell-opts))) - (define (builtin ast) (when (> %debug-level 0) (format (current-error-port) "builtin ast=~s\n" ast)) @@ -307,19 +296,6 @@ command))) (else #f))))) -;; FIXME: export/env vs set -(define %global-variables - (map identity ;; FIXME: make mutable - `(,(cons "SHELLOPTS" "") - ,(cons "PIPESTATUS" "([0]=\"0\"") - ,(cons "?" "0") - ,@(map (lambda (key-value) - (let* ((key-value (string-split key-value #\=)) - (key (car key-value)) - (value (cadr key-value))) - (cons key value))) - (environ))))) - (define (glob pattern) (define (glob? pattern) (and (string? pattern) (string-match "\\?|\\*" pattern))) @@ -355,14 +331,6 @@ (define (doublequotes . o) (string-join (append-map glob o) "")) -(define (assignment name value) - (set! %global-variables - (assoc-set! %global-variables name value)) - #t) - -(define (variable name) - (or (assoc-ref %global-variables (string-drop name 1)) "")) - (define (expression . args) (append-map glob args)) From 97a95ee0020f73ef5abc6040e4d8f2a1cc6dfbb8 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 15:14:05 +0200 Subject: [PATCH 127/312] builtins: cd: Support `cd -'. * gash/builtins.scm (cd-command): Support `cd -'. --- gash/builtins.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/gash/builtins.scm b/gash/builtins.scm index e4c0286..40d9e42 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -48,9 +48,11 @@ (define (cd-command . args) (match args - (() (chdir (getenv "HOME"))) + (() (cd-command (getenv "HOME"))) ((dir) - (chdir dir)) + (assignment "OLDPWD" (getcwd)) + (if (string=? dir "-") (chdir (variable "OLDPWD")) + (chdir dir))) ((args ...) (format (current-error-port) "cd: too many arguments: ~a\n" (string-join args))))) From 43d418fab124c83b89b25371b38175f02a93b52c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 15:41:03 +0200 Subject: [PATCH 128/312] some builtin progress WIP --- gash/peg.scm | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/gash/peg.scm b/gash/peg.scm index 4eec087..de75bf6 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -259,9 +259,13 @@ (match ast (('script o ...) (map transform o)) (('substitution o) `(substitution ,@(transform o))) - (('pipeline o) (pk `(pipeline ,(let ((c (warn 'transform (transform o)))) (or (builtin c) c))))) + (('pipeline o) (pk `(pipeline ,(transform o)))) (('pipeline h t) (pk `(pipeline ,(transform h) ,@(map transform t)))) - (('command o ...) `(command ,@(map transform o))) + (('command o ...) (let ((command (map transform o))) + (when (> %debug-level 1) + (format (current-error-port) "transform command=~s\n" command)) + (or (builtin command) + `(command ,@command)))) (('literal o) (transform o)) (('name o) o) (('number o) o) @@ -275,19 +279,21 @@ (_ ast))) (define (builtin ast) + ;; FIXME: distinguish between POSIX compliant builtins and + ;; `best-effort'/`fallback'? + "Possibly modify command to use a builtin." (when (> %debug-level 0) (format (current-error-port) "builtin ast=~s\n" ast)) (receive (command args) (match ast - (('command (and (? string?) command) args ...) (values command args)) - ;; ((('append ('glob command) args ...)) (values command args)) - ;; ((('glob command)) (values command #f)) + (((and (? string?) command) args ...) (values command args)) (_ (values #f #f))) - (let ((program (and command (PATH-search-path command)))) + (let ((program (and command + (not %prefer-builtins?) + (PATH-search-path command)))) (when (> %debug-level 0) - (format (current-error-port) "command ~a => ~s ~s\n" program command args)) - (cond ((and program (not %prefer-builtins?)) - #f) + (format (current-error-port) "command ~a => ~s ~s\n" (or program 'builtin) command args)) + (cond (program #f) ((and command (assoc-ref %builtin-commands command)) => (lambda (command) From e5c6324d822216b7c7d13c5660ae9fd9c3ff7370 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 15:56:46 +0200 Subject: [PATCH 129/312] remove debugging WIP: --- gash/peg.scm | 2 -- 1 file changed, 2 deletions(-) diff --git a/gash/peg.scm b/gash/peg.scm index de75bf6..88ffa48 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -354,9 +354,7 @@ (cut apply (compose (lambda (status) ((compose (cut assignment "?" <>) number->string) status) status) - (cut warn 'exit-val <>) status:exit-val - (cut warn 'status <>) system*) command)) (else (lambda () #t)))) (exec (append-map glob args))) From e0169d0acd2123a8ccedacd950d3519eaf06e22d Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 15:57:02 +0200 Subject: [PATCH 130/312] builtins: Support \non-builtin escape. * gash/peg.scm (builtin): Add #:prefer-builtin? keyword argument. (transform): Support \non-builtin escape. --- gash/peg.scm | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/gash/peg.scm b/gash/peg.scm index 88ffa48..7d7b19e 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -261,10 +261,15 @@ (('substitution o) `(substitution ,@(transform o))) (('pipeline o) (pk `(pipeline ,(transform o)))) (('pipeline h t) (pk `(pipeline ,(transform h) ,@(map transform t)))) - (('command o ...) (let ((command (map transform o))) + (('command o ...) (let* ((command (map transform o)) + (program (car command)) + (escape-builtin? (string-prefix? "\\" program)) + (program (if escape-builtin? (string-drop program 1) program)) + (command (cons program (cdr command)))) (when (> %debug-level 1) (format (current-error-port) "transform command=~s\n" command)) - (or (builtin command) + (or (builtin command #:prefer-builtin? (and %prefer-builtins? + (not escape-builtin?))) `(command ,@command)))) (('literal o) (transform o)) (('name o) o) @@ -278,7 +283,7 @@ (('else-part o ...) `(begin ,@(map transform o))) (_ ast))) -(define (builtin ast) +(define* (builtin ast #:key prefer-builtin?) ;; FIXME: distinguish between POSIX compliant builtins and ;; `best-effort'/`fallback'? "Possibly modify command to use a builtin." @@ -289,11 +294,10 @@ (((and (? string?) command) args ...) (values command args)) (_ (values #f #f))) (let ((program (and command - (not %prefer-builtins?) (PATH-search-path command)))) (when (> %debug-level 0) (format (current-error-port) "command ~a => ~s ~s\n" (or program 'builtin) command args)) - (cond (program #f) + (cond ((and program (not prefer-builtin?)) #f) ((and command (assoc-ref %builtin-commands command)) => (lambda (command) From 2c30f3c4c65999dbcdd332784f49155c77d2d5dc Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 16:44:56 +0200 Subject: [PATCH 131/312] builtins: find: First naive implementation. * gash/builtins.scm (find-command-implementation): New function. (find-command): New command. (%builtin-commands): Add it. * gash/guix-build-utils.scm (file-name-predicate, find-files): Import from Guix. --- gash/builtins.scm | 40 +++++++++++++++++++++++-- gash/guix-build-utils.scm | 61 +++++++++++++++++++++++++++++++++++++-- 2 files changed, 97 insertions(+), 4 deletions(-) diff --git a/gash/builtins.scm b/gash/builtins.scm index 40d9e42..8b3b4e0 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -17,6 +17,7 @@ ;;; along with Gash. If not, see . (define-module (gash builtins) + #:use-module (ice-9 getopt-long) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -26,9 +27,9 @@ #:use-module (gash config) #:use-module (gash environment) #:use-module (gash gash) - #:use-module (gash job) + #:use-module (gash guix-build-utils) #:use-module (gash io) - ;;#:use-module (gash peg) + #:use-module (gash job) #:export ( %builtin-commands @@ -38,6 +39,7 @@ echo-command exit-command fg-command + find-command help-command pwd-command set-command @@ -108,6 +110,39 @@ mostly works, pipes work, some redirections work. (define cp-command (wrap-command cp-command-implementation "cp")) +(define find-command-implementation + ;; Run-time support procedure. + (case-lambda + (() + (find-command-implementation ".")) + (args + (let* ((option-spec + '((help) + (version))) + (options (getopt-long (cons "ls" args) option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '())) + (files (if (null? files) '(".") files)) + (file (car files))) + (when (> (length files) 1) + (format (current-error-port) "find: too many FILEs: ~s\n" files) + (error "find failed")) + ;; TODO: find [OPTION]... [FILE]... [EXPRESSION]... + ;; and options: esp: -x, -L + (cond (help? (display "Usage: find [OPTION]... [FILE] + +Options: + --help display this help and exit + --version display version information and exit +")) + (version? (format #t "find (GASH) ~a\n" %version)) + (else + (let* ((files (find-files file #:directories? #t #:fail-on-error? #t))) + (for-each stdout files)))))))) + +(define find-command (wrap-command find-command-implementation "find")) + (define %builtin-commands `( ("bg" . ,bg-command) @@ -117,6 +152,7 @@ mostly works, pipes work, some redirections work. ("echo" . ,echo-command) ("exit" . ,exit-command) ("fg" . ,fg-command) + ("find" . ,find-command) ("help" . ,help-command) ("jobs" . ,jobs-command) ("ls" . ,ls-command) diff --git a/gash/guix-build-utils.scm b/gash/guix-build-utils.scm index 002e43b..b3637c1 100644 --- a/gash/guix-build-utils.scm +++ b/gash/guix-build-utils.scm @@ -27,7 +27,7 @@ ;; #:use-module (srfi srfi-34) ;; #:use-module (srfi srfi-35) ;; #:use-module (srfi srfi-60) - ;; #:use-module (ice-9 ftw) + #:use-module (ice-9 ftw) ;; #:use-module (ice-9 match) ;; #:use-module (ice-9 regex) ;; #:use-module (ice-9 rdelim) @@ -35,12 +35,69 @@ ;; #:use-module (ice-9 threads) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) - #:export (dump-port)) + #:export ( + dump-port + file-name-predicate + find-files + )) ;;; Commentary: ;;; This code is taken from (guix build utils) +;;; +;;; Directories. +;;; + +(define (file-name-predicate regexp) + "Return a predicate that returns true when passed a file name whose base +name matches REGEXP." + (let ((file-rx (if (regexp? regexp) + regexp + (make-regexp regexp)))) + (lambda (file stat) + (regexp-exec file-rx (basename file))))) + +(define* (find-files dir #:optional (pred (const #t)) + #:key (stat lstat) + directories? + fail-on-error?) + "Return the lexicographically sorted list of files under DIR for which PRED +returns true. PRED is passed two arguments: the absolute file name, and its +stat buffer; the default predicate always returns true. PRED can also be a +regular expression, in which case it is equivalent to (file-name-predicate +PRED). STAT is used to obtain file information; using 'lstat' means that +symlinks are not followed. If DIRECTORIES? is true, then directories will +also be included. If FAIL-ON-ERROR? is true, raise an exception upon error." + (let ((pred (if (procedure? pred) + pred + (file-name-predicate pred)))) + ;; Sort the result to get deterministic results. + (sort (file-system-fold (const #t) + (lambda (file stat result) ; leaf + (if (pred file stat) + (cons file result) + result)) + (lambda (dir stat result) ; down + (if (and directories? + (pred dir stat)) + (cons dir result) + result)) + (lambda (dir stat result) ; up + result) + (lambda (file stat result) ; skip + result) + (lambda (file stat errno result) + (format (current-error-port) "find-files: ~a: ~a~%" + file (strerror errno)) + (when fail-on-error? + (error "find-files failed")) + result) + '() + dir + stat) + string Date: Sat, 14 Jul 2018 16:58:50 +0200 Subject: [PATCH 132/312] debug du WIP --- gash/pipe.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gash/pipe.scm b/gash/pipe.scm index aaba6e9..1d2ad5a 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -107,7 +107,7 @@ (let ((file (string-append debug-id "." id))) (cons* command `("tee" ,file) lst))) '() commands (map number->string (iota (length commands)))))) - (foo (when (> %debug-level 0) (with-output-to-file debug-id (cut format #t "COMMANDS: ~s\n" commands)))) + (foo (when (> %debug-level 1) (with-output-to-file debug-id (cut format #t "COMMANDS: ~s\n" commands)))) (ports (if (> (length commands) 1) (let loop ((input (spawn fg? job (car commands) '())) ;; spawn-source (commands (cdr commands))) From 0408463a13962a9fa83af2051fd325daf71b319e Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 17:18:18 +0200 Subject: [PATCH 133/312] bah, some uninformed error handling. WIP --- gash/peg.scm | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/gash/peg.scm b/gash/peg.scm index 7d7b19e..620d59c 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -294,10 +294,21 @@ (((and (? string?) command) args ...) (values command args)) (_ (values #f #f))) (let ((program (and command - (PATH-search-path command)))) + (cond ((string-prefix? "/" command) + (when (not (file-exists? command)) + (format (current-error-port) "gash: ~a: no such file or directory\n" command)) + command) + (else (PATH-search-path command)))))) + ;; FIXME: find some generic strerror/errno way: what about permissions and stuff? + ;; after calling system* we're too late for that? + (when (not program) + (format (current-error-port) "gash: ~a: command not found\n" command)) (when (> %debug-level 0) (format (current-error-port) "command ~a => ~s ~s\n" (or program 'builtin) command args)) - (cond ((and program (not prefer-builtin?)) #f) + (cond ((and program (not prefer-builtin?)) + (when (not (access? program X_OK)) + (format (current-error-port) "gash: ~a: permission denied\n" command)) + #f) ((and command (assoc-ref %builtin-commands command)) => (lambda (command) @@ -358,6 +369,10 @@ (cut apply (compose (lambda (status) ((compose (cut assignment "?" <>) number->string) status) status) + (lambda (status) + (when (not (zero? status)) + (format (current-error-port) "*****gash: ~a: ~a" (car command) (strerror status))) + status) status:exit-val system*) command)) (else (lambda () #t)))) From 677deaf9b371ea88d27043c97d5182ca2108fbca Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 18:05:41 +0200 Subject: [PATCH 134/312] builtins: command: New command. * gash/builtins.scm (command-command): New command. (%builtin-commands): Add it. (builtin): Move from peg. * gash/peg.scm (builtin): Remove. --- gash/builtins.scm | 117 +++++++++++++++++++++++++++++++++++++++------- gash/peg.scm | 35 -------------- 2 files changed, 99 insertions(+), 53 deletions(-) diff --git a/gash/builtins.scm b/gash/builtins.scm index 8b3b4e0..5bc2a1f 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -18,7 +18,9 @@ (define-module (gash builtins) #:use-module (ice-9 getopt-long) + #:use-module (ice-9 local-eval) #:use-module (ice-9 match) + #:use-module (ice-9 receive) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -33,7 +35,7 @@ #:export ( %builtin-commands - PATH-search-path + builtin bg-command cd-command echo-command @@ -48,6 +50,40 @@ (define (PATH-search-path program) (search-path (string-split (getenv "PATH") #\:) program)) +(define* (builtin ast #:key prefer-builtin?) + ;; FIXME: distinguish between POSIX compliant builtins and + ;; `best-effort'/`fallback'? + "Possibly modify command to use a builtin." + (when (> %debug-level 0) + (format (current-error-port) "builtin ast=~s\n" ast)) + (receive (command args) + (match ast + (((and (? string?) command) args ...) (values command args)) + (_ (values #f #f))) + (let ((program (and command + (cond ((string-prefix? "/" command) + (when (not (file-exists? command)) + (format (current-error-port) "gash: ~a: no such file or directory\n" command)) + command) + (else (PATH-search-path command)))))) + ;; FIXME: find some generic strerror/errno way: what about permissions and stuff? + ;; after calling system* we're too late for that? + (when (> %debug-level 0) + (format (current-error-port) "command ~a => ~s ~s\n" (or program 'builtin) command args)) + (cond ((and program (not prefer-builtin?)) + (when (not program) + (format (current-error-port) "gash: ~a: command not found\n" command)) + (when (not (access? program X_OK)) + (format (current-error-port) "gash: ~a: permission denied\n" command)) + #f) + ((and command (assoc-ref %builtin-commands command)) + => + (lambda (command) + (if args + `(,apply ,command ',(map (cut local-eval <> (the-environment)) args)) + command))) + (else #f))))) + (define (cd-command . args) (match args (() (cd-command (getenv "HOME"))) @@ -143,23 +179,68 @@ Options: (define find-command (wrap-command find-command-implementation "find")) +(define command-command + (case-lambda + (() #t) + (args + (let* ((option-spec + '((describe (single-char #\V)) + (help) + (show (single-char #\v)) + (version))) + (options (getopt-long (cons "ls" args) option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (cond (help? (display "Usage: command [OPTION]... [COMMAND [ARG]...] + +Options: + --help display this help and exit + --version display version information and exit + -v display a description of COMMAND similar to the `type' builtin + -V display a more verbose description of COMMAND +")) + (version? (format #t "command (GASH) ~a\n" %version)) + ((null? files) #t) + ((option-ref options 'describe #f) + (let* ((command (car files)) + (builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?))) + (cond (builtin (format #t "~a is a shell builtin\n" command) + 0) + (else (let ((program (PATH-search-path command))) + (if (string? program) (begin (format #t "~a hashed (~a)\n" command ) 0) + 1)))))) + ((option-ref options 'show #f) + (let* ((command (car files)) + (builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?))) + (if builtin (begin (stdout command) 0) + (let ((program (PATH-search-path command))) + (if (string? program) (begin (stdout program) 0) + 1))))) + (else (let* ((command (car files)) + (builtin (builtin command #:prefer-builtin? %prefer-builtins?))) + ;; FIXME: + `(command ,@args)))))))) + + (define %builtin-commands `( - ("bg" . ,bg-command) - ("cat" . ,cat-command) - ("cd" . ,cd-command) - ("cp" . ,cp-command) - ("echo" . ,echo-command) - ("exit" . ,exit-command) - ("fg" . ,fg-command) - ("find" . ,find-command) - ("help" . ,help-command) - ("jobs" . ,jobs-command) - ("ls" . ,ls-command) - ("pwd" . ,pwd-command) - ("reboot" . ,reboot-command) - ("rm" . ,rm-command) - ("set" . ,set-command) - ("wc" . ,wc-command) - ("which" . ,which-command) + ("bg" . ,bg-command) + ("cat" . ,cat-command) + ("command" . ,command-command) + ("cd" . ,cd-command) + ("cp" . ,cp-command) + ("echo" . ,echo-command) + ("exit" . ,exit-command) + ("fg" . ,fg-command) + ("find" . ,find-command) + ("help" . ,help-command) + ("jobs" . ,jobs-command) + ("ls" . ,ls-command) + ("pwd" . ,pwd-command) + ("reboot" . ,reboot-command) + ("rm" . ,rm-command) + ("set" . ,set-command) + ("wc" . ,wc-command) + ("which" . ,which-command) )) diff --git a/gash/peg.scm b/gash/peg.scm index 620d59c..4c71e2f 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -5,7 +5,6 @@ #:use-module (ice-9 pretty-print) #:use-module (ice-9 peg) #:use-module (ice-9 peg codegen) - #:use-module (ice-9 receive) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) @@ -283,40 +282,6 @@ (('else-part o ...) `(begin ,@(map transform o))) (_ ast))) -(define* (builtin ast #:key prefer-builtin?) - ;; FIXME: distinguish between POSIX compliant builtins and - ;; `best-effort'/`fallback'? - "Possibly modify command to use a builtin." - (when (> %debug-level 0) - (format (current-error-port) "builtin ast=~s\n" ast)) - (receive (command args) - (match ast - (((and (? string?) command) args ...) (values command args)) - (_ (values #f #f))) - (let ((program (and command - (cond ((string-prefix? "/" command) - (when (not (file-exists? command)) - (format (current-error-port) "gash: ~a: no such file or directory\n" command)) - command) - (else (PATH-search-path command)))))) - ;; FIXME: find some generic strerror/errno way: what about permissions and stuff? - ;; after calling system* we're too late for that? - (when (not program) - (format (current-error-port) "gash: ~a: command not found\n" command)) - (when (> %debug-level 0) - (format (current-error-port) "command ~a => ~s ~s\n" (or program 'builtin) command args)) - (cond ((and program (not prefer-builtin?)) - (when (not (access? program X_OK)) - (format (current-error-port) "gash: ~a: permission denied\n" command)) - #f) - ((and command (assoc-ref %builtin-commands command)) - => - (lambda (command) - (if args - `(,apply ,command ',(map (cut local-eval <> (the-environment)) args)) - command))) - (else #f))))) - (define (glob pattern) (define (glob? pattern) (and (string? pattern) (string-match "\\?|\\*" pattern))) From de6d653c7c0a57b7187ef858dd81f84ab20438ae Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 18:23:59 +0200 Subject: [PATCH 135/312] builtins: type: New command. * gash/builtins.scm (type-command): New function. (%builtin-commands): Add it. --- gash/builtins.scm | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/gash/builtins.scm b/gash/builtins.scm index 5bc2a1f..3a8920e 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -222,6 +222,43 @@ Options: ;; FIXME: `(command ,@args)))))))) +(define type-command + (case-lambda + (() #t) + (args + (let* ((option-spec + '((help) + (canonical-file-name (single-char #\p)) + (version))) + (options (getopt-long (cons "ls" args) option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (cond (help? (display "Usage: type [OPTION]... [COMMAND] + +Options: + --help display this help and exit + -p display canonical file name of COMMAND + --version display version information and exit +")) + (version? (format #t "type (GASH) ~a\n" %version)) + ((null? files) #t) + ((option-ref options 'canonical-file-name #f) + (let* ((command (car files)) + (builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?))) + (if builtin 0 + (let ((program (PATH-search-path command))) + (and (string? program) + (stdout program) + 0))))) + (else + (let* ((command (car files)) + (builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?))) + (cond (builtin (format #t "~a is a shell builtin\n" command) + 0) + (else (let ((program (PATH-search-path command))) + (if (string? program) (begin (format #t "~a hashed (~a)\n" command ) 0) + 1))))))))))) (define %builtin-commands `( @@ -241,6 +278,7 @@ Options: ("reboot" . ,reboot-command) ("rm" . ,rm-command) ("set" . ,set-command) + ("type" . ,type-command) ("wc" . ,wc-command) ("which" . ,which-command) )) From 48373edb3f52aaa111b5a803eb587d9213b450ad Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 19:45:30 +0200 Subject: [PATCH 136/312] WIP: IF hack --- gash/peg.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/gash/peg.scm b/gash/peg.scm index 4c71e2f..2c1f575 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -262,7 +262,9 @@ (('pipeline h t) (pk `(pipeline ,(transform h) ,@(map transform t)))) (('command o ...) (let* ((command (map transform o)) (program (car command)) - (escape-builtin? (string-prefix? "\\" program)) + ;; if [ 0 = 1 ] ... program = '(if ...) not a string + ;; this escape-builtin? is probably not deep enough? + (escape-builtin? (and (string? program) (string-prefix? "\\" program))) (program (if escape-builtin? (string-drop program 1) program)) (command (cons program (cdr command)))) (when (> %debug-level 1) From 863b3b59089e0c30b614638c9176f5772f928444 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 20:11:05 +0200 Subject: [PATCH 137/312] builtins: test: New command. * gash/builtins.scm (test-command): New command. (%builtin-commands): Add it. (builtin, command, doublequotes, expression, for, glob, singlequotes, substitution): Move from peg.scm. * gash/peg.scm: Remove them. --- gash/builtins.scm | 235 ++++++++++++++++++++++++++++++++++++++-------- gash/peg.scm | 121 ------------------------ 2 files changed, 198 insertions(+), 158 deletions(-) diff --git a/gash/builtins.scm b/gash/builtins.scm index 3a8920e..e1f260a 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -21,6 +21,7 @@ #:use-module (ice-9 local-eval) #:use-module (ice-9 match) #:use-module (ice-9 receive) + #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -32,10 +33,21 @@ #:use-module (gash guix-build-utils) #:use-module (gash io) #:use-module (gash job) + #:use-module (gash peg) ; pipeline #:export ( %builtin-commands builtin + pipeline + command + glob + singlequotes + doublequotes + expression + for + substitution + sh-exec + bg-command cd-command echo-command @@ -46,43 +58,6 @@ pwd-command set-command )) - -(define (PATH-search-path program) - (search-path (string-split (getenv "PATH") #\:) program)) - -(define* (builtin ast #:key prefer-builtin?) - ;; FIXME: distinguish between POSIX compliant builtins and - ;; `best-effort'/`fallback'? - "Possibly modify command to use a builtin." - (when (> %debug-level 0) - (format (current-error-port) "builtin ast=~s\n" ast)) - (receive (command args) - (match ast - (((and (? string?) command) args ...) (values command args)) - (_ (values #f #f))) - (let ((program (and command - (cond ((string-prefix? "/" command) - (when (not (file-exists? command)) - (format (current-error-port) "gash: ~a: no such file or directory\n" command)) - command) - (else (PATH-search-path command)))))) - ;; FIXME: find some generic strerror/errno way: what about permissions and stuff? - ;; after calling system* we're too late for that? - (when (> %debug-level 0) - (format (current-error-port) "command ~a => ~s ~s\n" (or program 'builtin) command args)) - (cond ((and program (not prefer-builtin?)) - (when (not program) - (format (current-error-port) "gash: ~a: command not found\n" command)) - (when (not (access? program X_OK)) - (format (current-error-port) "gash: ~a: permission denied\n" command)) - #f) - ((and command (assoc-ref %builtin-commands command)) - => - (lambda (command) - (if args - `(,apply ,command ',(map (cut local-eval <> (the-environment)) args)) - command))) - (else #f))))) (define (cd-command . args) (match args @@ -260,6 +235,191 @@ Options: (if (string? program) (begin (format #t "~a hashed (~a)\n" command ) 0) 1))))))))))) +(define test-command + (case-lambda + (() #f) + (args + (let* ((option-spec + '((help) + (version))) + (options (getopt-long (cons "ls" args) option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (cond (help? (display "Usage: test [EXPRESSION] + +Options: + --help display this help and exit + --version display version information and exit +")) + (version? (format #t "test (GASH) ~a\n" %version)) + ((null? files) #f) + (else + (match files + ((or (left "=" right) + (left "==" right)) + (equal? left right)) + (expression + (let ((status (sh-exec `(pipeline (command ',expression))))) + (zero? status)))))))))) + +(define (PATH-search-path program) + (search-path (string-split (getenv "PATH") #\:) program)) + +(define* (builtin ast #:key prefer-builtin?) + ;; FIXME: distinguish between POSIX compliant builtins and + ;; `best-effort'/`fallback'? + "Possibly modify command to use a builtin." + (when (> %debug-level 0) + (format (current-error-port) "builtin ast=~s\n" ast)) + (receive (command args) + (match ast + (((and (? string?) command) args ...) (values command args)) + (_ (values #f #f))) + (let ((program (and command + (cond ((string-prefix? "/" command) + (when (not (file-exists? command)) + (format (current-error-port) "gash: ~a: no such file or directory\n" command)) + command) + (else (PATH-search-path command)))))) + ;; FIXME: find some generic strerror/errno way: what about permissions and stuff? + ;; after calling system* we're too late for that? + (when (> %debug-level 0) + (format (current-error-port) "command ~a => ~s ~s\n" (or program 'builtin) command args)) + (cond ((and program (not prefer-builtin?)) + (when (not program) + (format (current-error-port) "gash: ~a: command not found\n" command)) + (when (not (access? program X_OK)) + (format (current-error-port) "gash: ~a: permission denied\n" command)) + #f) + ((and command (assoc-ref %builtin-commands command)) + => + (lambda (command) + (if args + `(,apply ,command ',(map (cut local-eval <> (the-environment)) args)) + command))) + (else #f))))) + +(define (command . args) + (define (exec command) + (cond ((procedure? command) command) + ((every string? command) (cut apply (compose status:exit-val system*) command)) + ;; not sure whether to do $?/PIPESTATUS here or in sh-exec + ((every string? command) + (cut apply (compose (lambda (status) + ((compose (cut assignment "?" <>) number->string) status) + status) + (lambda (status) + (when (not (zero? status)) + (format (current-error-port) "*****gash: ~a: ~a" (car command) (strerror status))) + status) + status:exit-val + system*) command)) + (else (lambda () #t)))) + (exec (append-map glob args))) + +(define (glob pattern) + (define (glob? pattern) + (and (string? pattern) (string-match "\\?|\\*" pattern))) + (define (glob2regex pattern) + (let* ((pattern (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post)) + (pattern (regexp-substitute/global #f "\\?" pattern 'pre "." 'post)) + (pattern (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post))) + (make-regexp (string-append "^" pattern "$")))) + (define (glob-match regex path) ;; pattern path -> bool + (regexp-match? (regexp-exec regex path))) + (define (glob- pattern paths) + (map (lambda (path) + (if (string-prefix? "./" path) (string-drop path 2) path)) + (append-map (lambda (path) + (map (cute string-append (if (string=? "/" path) "" path) "/" <>) + (filter (conjoin (negate (cut string-prefix? "." <>)) + (cute glob-match (glob2regex pattern) <>)) + (or (scandir path) '())))) + paths))) + (cond + ((not pattern) '("")) + ((glob? pattern) (let ((absolute? (string-prefix? "/" pattern))) + (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) + (paths (if absolute? '("/") '(".")))) + (if (null? patterns) + paths + (loop (cdr patterns) (glob- (car patterns) paths)))))) + (#t (list pattern)))) + +(define (singlequotes . o) + (string-join o "")) + +(define (doublequotes . o) + (string-join (append-map glob o) "")) + +(define (expression . args) + (append-map glob args)) + +(define (for name expr body) + (for-each (lambda (value) + (assignment name value) + (body)) (expr))) + +(define (substitution . commands) + (apply (@ (gash pipe) pipeline->string) (map cdr commands))) ;;HACK + +(define (sh-exec ast) + (define (exec cmd) + (when (> %debug-level 0) + (format (current-error-port) "sh-exec:exec cmd=~s\n" cmd)) + (let* ((job (local-eval cmd (the-environment))) + (stati (cond ((job? job) (map status:exit-val (job-status job))) + ((boolean? job) (list (if job 0 1))) + ((number? job) (list job)) + (else (list 0)))) + (status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0) + (car stati))) + (pipestatus (string-append + "(" + (string-join + (map (lambda (s i) + (format #f "[~a]=\"~a\"" s i)) + stati + (iota (length stati)))) + ")"))) + (assignment "PIPESTATUS" pipestatus) + (assignment "?" (number->string status)) + (when (and (not (zero? status)) + (shell-opt? "errexit")) + (exit status)) + status)) + (when (> %debug-level 1) + (format (current-error-port) "sh-exec:exec ast=~s\n" ast)) + (match ast + ('script #t) ;; skip + (('pipeline commands ...) + (when (shell-opt? "xtrace") + (for-each + (lambda (o) + (match o + (('command command ...) + ;;(format (current-error-port) "+ ~a\n" (string-join command)) + ;; FIXME: side-effects done twice?! + ;; '(variable "$?"): not a string...hmm + (format (current-error-port) "+ ~a\n" (string-join (map (cut local-eval <> (the-environment)) command))) + ) + (_ (format (current-error-port) "FIXME trace:~s" o)))) + (reverse commands))) + (exec ast)) + (_ (for-each exec ast)))) + +(define (pipeline . commands) + (when (> %debug-level 1) + (format (current-error-port) "pijp: commands=~s\n" commands)) + ;; FIXME: after running a builtin, we still end up here with the builtin's result + ;; that should probably not happen, however, cater for it here for now + (match commands + (((and (? boolean?) boolean)) (if boolean 0 1)) + (((and (? number?) number)) number) + (((? unspecified?)) 0) + (_ (apply (@ (gash pipe) pipeline) #t commands)))) + (define %builtin-commands `( ("bg" . ,bg-command) @@ -278,6 +438,7 @@ Options: ("reboot" . ,reboot-command) ("rm" . ,rm-command) ("set" . ,set-command) + ("test" . ,test-command) ("type" . ,type-command) ("wc" . ,wc-command) ("which" . ,which-command) diff --git a/gash/peg.scm b/gash/peg.scm index 2c1f575..4ae1232 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -191,52 +191,6 @@ (format (current-error-port) "parse error: no match\n") #f))))) -(define (sh-exec ast) - (define (exec cmd) - (when (> %debug-level 0) - (format (current-error-port) "sh-exec:exec cmd=~s\n" cmd)) - (let* ((job (local-eval cmd (the-environment))) - (stati (cond ((job? job) (map status:exit-val (job-status job))) - ((boolean? job) (list (if job 0 1))) - ((number? job) (list job)) - (else (list 0)))) - (status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0) - (car stati))) - (pipestatus (string-append - "(" - (string-join - (map (lambda (s i) - (format #f "[~a]=\"~a\"" s i)) - stati - (iota (length stati)))) - ")"))) - (assignment "PIPESTATUS" pipestatus) - (assignment "?" (number->string status)) - (when (and (not (zero? status)) - (shell-opt? "errexit")) - (exit status)) - status)) - (when (> %debug-level 1) - (format (current-error-port) "sh-exec:exec ast=~s\n" ast)) - (match ast - ('script #t) ;; skip - (('pipeline commands ...) - (when (shell-opt? "xtrace") - (for-each - (lambda (o) - (match o - (('command command ...) - ;;(format (current-error-port) "+ ~a\n" (string-join command)) - ;; FIXME: side-effects done twice?! - ;; '(variable "$?"): not a string...hmm - (format (current-error-port) "+ ~a\n" (string-join (map (cut local-eval <> (the-environment)) command))) - ) - (_ (format (current-error-port) "FIXME trace:~s" o)))) - (reverse commands))) - (exec ast)) - (_ (for-each exec ast)))) - - (define (parse input) (let* ((pt (parse- input)) (foo (pretty-print pt)) @@ -283,78 +237,3 @@ (('then-part o ...) `(begin ,@(map transform o))) (('else-part o ...) `(begin ,@(map transform o))) (_ ast))) - -(define (glob pattern) - (define (glob? pattern) - (and (string? pattern) (string-match "\\?|\\*" pattern))) - (define (glob2regex pattern) - (let* ((pattern (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post)) - (pattern (regexp-substitute/global #f "\\?" pattern 'pre "." 'post)) - (pattern (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post))) - (make-regexp (string-append "^" pattern "$")))) - (define (glob-match regex path) ;; pattern path -> bool - (regexp-match? (regexp-exec regex path))) - (define (glob- pattern paths) - (map (lambda (path) - (if (string-prefix? "./" path) (string-drop path 2) path)) - (append-map (lambda (path) - (map (cute string-append (if (string=? "/" path) "" path) "/" <>) - (filter (conjoin (negate (cut string-prefix? "." <>)) - (cute glob-match (glob2regex pattern) <>)) - (or (scandir path) '())))) - paths))) - (cond - ((not pattern) '("")) - ((glob? pattern) (let ((absolute? (string-prefix? "/" pattern))) - (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) - (paths (if absolute? '("/") '(".")))) - (if (null? patterns) - paths - (loop (cdr patterns) (glob- (car patterns) paths)))))) - (#t (list pattern)))) - -(define (singlequotes . o) - (string-join o "")) - -(define (doublequotes . o) - (string-join (append-map glob o) "")) - -(define (expression . args) - (append-map glob args)) - -(define (for name expr body) - (for-each (lambda (value) - (assignment name value) - (body)) (expr))) - -(define (command . args) - (define (exec command) - (cond ((procedure? command) command) - ((every string? command) (cut apply (compose status:exit-val system*) command)) - ;; not sure whether to do $?/PIPESTATUS here or in sh-exec - ((every string? command) - (cut apply (compose (lambda (status) - ((compose (cut assignment "?" <>) number->string) status) - status) - (lambda (status) - (when (not (zero? status)) - (format (current-error-port) "*****gash: ~a: ~a" (car command) (strerror status))) - status) - status:exit-val - system*) command)) - (else (lambda () #t)))) - (exec (append-map glob args))) - -(define (substitution . commands) - (apply (@ (gash pipe) pipeline->string) (map cdr commands))) ;;HACK - -(define (pipeline . commands) - (when (> %debug-level 1) - (format (current-error-port) "pijp: commands=~s\n" commands)) - ;; FIXME: after running a builtin, we still end up here with the builtin's result - ;; that should probably not happen, however, cater for it here for now - (match commands - (((and (? boolean?) boolean)) (if boolean 0 1)) - (((and (? number?) number)) number) - (((? unspecified?)) 0) - (_ (apply (@ (gash pipe) pipeline) #t commands)))) From 0cab9321b2b59c008f6381727c3a3d86c4c6d9dd Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 20:46:52 +0200 Subject: [PATCH 138/312] builtins: test: Enhance with file tests. * gash/guix-build-utils.scm (directory-exists?, executable-file?, symbolic-link?): Import from Guix. * gash/builtins.scm (test-command): Use them to enhance with file test. --- gash/builtins.scm | 48 +++++++++++++++++++++++++++++++++++---- gash/guix-build-utils.scm | 20 ++++++++++++++++ 2 files changed, 64 insertions(+), 4 deletions(-) diff --git a/gash/builtins.scm b/gash/builtins.scm index e1f260a..1963c4c 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -240,28 +240,68 @@ Options: (() #f) (args (let* ((option-spec - '((help) + '((is-directory (single-char #\d)) + (exists (single-char #\e)) + (has-size (single-char #\s)) + (help) + (is-directory (single-char #\d)) + (is-file (single-char #\f)) + (is-symbolic-link (single-char #\L)) + (is-symbolic-link (single-char #\h)) + (is-readable (single-char #\r)) + (is-writable (single-char #\w)) + (is-exeutable (single-char #\x)) (version))) (options (getopt-long (cons "ls" args) option-spec)) (help? (option-ref options 'help #f)) (version? (option-ref options 'version #f)) - (files (option-ref options '() '()))) + (files (option-ref options '() '())) + (file (and (pair? files) (car files)))) (cond (help? (display "Usage: test [EXPRESSION] Options: + -d FILE FILE exists and is a directory + -e FILE FILE exists + -f FILE FILE exists and is a regular file + -h FILE FILE exists and is a symbolic link (same as -L) + -L FILE FILE exists and is a symbolic link (same as -h) + -r FILE FILE exists and read permission is granted + -s FILE FILE exists and has a size greater than zero + -w FILE FILE exists and write permission is granted + -x FILE FILE exists and execute (or search) permission is granted --help display this help and exit --version display version information and exit ")) (version? (format #t "test (GASH) ~a\n" %version)) ((null? files) #f) - (else + ((and (= (length files) 3) + (member (cadr files) '("=" "=="))) (match files ((or (left "=" right) (left "==" right)) (equal? left right)) (expression (let ((status (sh-exec `(pipeline (command ',expression))))) - (zero? status)))))))))) + (zero? status))))) + ((not (= (length files) 1)) + (format (current-error-port) "test: too many files: ~a\n" files) + 1) + ((option-ref options 'is-directory #f) + (directory-exists? file)) + ((option-ref options 'exists #f) + (file-exists? file)) + ((option-ref options 'is-symbolic-link #f) + (symbolic-link? file)) + ((option-ref options 'is-readable #f) + (access? file R_OK)) + ((option-ref options 'has-size #f) + (and (file-exists? file) + (not (zero? (stat:size (stat file)))))) + ((option-ref options 'is-writable #f) + (access? file W_OK)) + ((option-ref options 'is-exeutable #f) + (access? file X_OK)) + (else #f)))))) (define (PATH-search-path program) (search-path (string-split (getenv "PATH") #\:) program)) diff --git a/gash/guix-build-utils.scm b/gash/guix-build-utils.scm index b3637c1..b070282 100644 --- a/gash/guix-build-utils.scm +++ b/gash/guix-build-utils.scm @@ -39,6 +39,10 @@ dump-port file-name-predicate find-files + + directory-exists? + executable-file? + symbolic-link? )) ;;; Commentary: @@ -49,6 +53,22 @@ ;;; Directories. ;;; +(define (directory-exists? dir) + "Return #t if DIR exists and is a directory." + (let ((s (stat dir #f))) + (and s + (eq? 'directory (stat:type s))))) + +(define (executable-file? file) + "Return #t if FILE exists and is executable." + (let ((s (stat file #f))) + (and s + (not (zero? (logand (stat:mode s) #o100)))))) + +(define (symbolic-link? file) + "Return #t if FILE is a symbolic link (aka. \"symlink\".)" + (eq? (stat:type (lstat file)) 'symlink)) + (define (file-name-predicate regexp) "Return a predicate that returns true when passed a file name whose base name matches REGEXP." From b20306e1235d00a89f8b28013a08c93adc7fca9c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 22:46:39 +0200 Subject: [PATCH 139/312] builtins: grep: New command. * gash/guix-build-utils.scm (): New record type. (grep): New function. * gash/builtins.scm (grep-command): New command. (%builtin-commands): Add it. --- gash/builtins.scm | 67 +++++++++++++++++++++++++++++++++++++++ gash/guix-build-utils.scm | 48 +++++++++++++++++++++------- 2 files changed, 104 insertions(+), 11 deletions(-) diff --git a/gash/builtins.scm b/gash/builtins.scm index 1963c4c..15656d5 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -20,6 +20,7 @@ #:use-module (ice-9 getopt-long) #:use-module (ice-9 local-eval) #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) #:use-module (ice-9 receive) #:use-module (ice-9 regex) @@ -303,6 +304,71 @@ Options: (access? file X_OK)) (else #f)))))) +(define grep-command + (case-lambda + (() #f) + (args + (let* ((option-spec + '((help) + (line-number (single-char #\n)) + (files-with-matches (single-char #\l)) + (files-without-match (single-char #\L)) + (with-file-name (single-char #\H)) + (no-file-name (single-char #\h)) + (only-matching (single-char #\o)) + (version (single-char #\V)))) + (options (getopt-long (cons "ls" args) option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (cond (help? (display "Usage: grep [OPTION]... PATTERN [FILE]... + +Options: + --help display this help and exit + -h, --no-filename suppress the file name prefix on output + -H, --with-filename print file name with output lines + -l, --files-with-matches print only names of FILEs with selected lines + -L, --files-without-match print only names of FILEs with no selected lines + -n, --line-number print line number with output lines + -o, --only-matching show only the part of a line matching PATTERN + -V, --version display version information and exit +")) + (version? (format #t "grep (GASH) ~a\n" %version)) + ((null? files) #t) + (else + (let* ((pattern (warn 'pattern (car files))) + (files (warn 'files (cdr files))) + (matches (append-map (cut grep pattern <>) files))) + (define (display-match o) + (let* ((s (grep-match-string o)) + (s (if (option-ref options 'only-matching #f) + (substring s (grep-match-column o) (grep-match-end-column o)) + s)) + (s (if (option-ref options 'line-number #f) + (string-append (number->string (grep-match-line o)) ":" s) + s)) + (s (if (option-ref options 'with-file-name #f) + (string-append (grep-match-file-name o) ":" s) + s))) + (stdout s))) + (define (files-with-matches) + (delete-duplicates (map grep-match-file-name matches))) + (cond ((option-ref options 'files-with-matches #f) + (let ((result (files-with-matches))) + (and (pair? result) + (for-each stdout result) + 0))) + ((option-ref options 'files-without-match #f) + (let* ((result (files-with-matches)) + (result (filter (negate (cut member <> result)) files))) + (and (pair? result) + (for-each stdout result) + 0))) + (else + (and (pair? matches) + (for-each display-match matches) + 0)))))))))) + (define (PATH-search-path program) (search-path (string-split (getenv "PATH") #\:) program)) @@ -471,6 +537,7 @@ Options: ("exit" . ,exit-command) ("fg" . ,fg-command) ("find" . ,find-command) + ("grep" . ,grep-command) ("help" . ,help-command) ("jobs" . ,jobs-command) ("ls" . ,ls-command) diff --git a/gash/guix-build-utils.scm b/gash/guix-build-utils.scm index b070282..dfeb773 100644 --- a/gash/guix-build-utils.scm +++ b/gash/guix-build-utils.scm @@ -21,24 +21,26 @@ (define-module (gash guix-build-utils) - ;; #:use-module (srfi srfi-1) - ;; #:use-module (srfi srfi-11) - ;; #:use-module (srfi srfi-26) - ;; #:use-module (srfi srfi-34) - ;; #:use-module (srfi srfi-35) - ;; #:use-module (srfi srfi-60) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) + #:use-module (ice-9 ftw) - ;; #:use-module (ice-9 match) - ;; #:use-module (ice-9 regex) - ;; #:use-module (ice-9 rdelim) - ;; #:use-module (ice-9 format) - ;; #:use-module (ice-9 threads) + #:use-module (ice-9 regex) + #:use-module (ice-9 rdelim) + #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:export ( dump-port file-name-predicate find-files + grep + + grep-match-file-name + grep-match-string + grep-match-line + grep-match-column + grep-match-end-column directory-exists? executable-file? @@ -142,3 +144,27 @@ transferred and the continuation of the transfer as a thunk." (progress 0 (lambda () (loop 0 (get-bytevector-n! in buffer 0 buffer-size))))) + +(define-immutable-record-type + (make-grep-match file-name string line column end-column) + grep-match? + (file-name grep-match-file-name) + (string grep-match-string) + (line grep-match-line) + (column grep-match-column) + (end-column grep-match-end-column)) + +(define (grep regexp file) + (call-with-input-file file + (lambda (in) + (let loop ((line (read-line in)) (ln 1) (matches '())) + (if (eof-object? line) (reverse matches) + (let* ((m (list-matches regexp line)) + (m (and (pair? m) (car m)))) + (loop (read-line in) (1+ ln) + (if m (cons (make-grep-match file + (match:string m) + ln + (match:start m) + (match:end m)) matches) + matches)))))))) From 4bb60cc4c3f6a10a15179dd09335f7009978d4ca Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 22:51:00 +0200 Subject: [PATCH 140/312] parse: handle empty script WIP --- gash/peg.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/gash/peg.scm b/gash/peg.scm index 4ae1232..0ba89a1 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -198,9 +198,10 @@ (foo (pretty-print ast))) (cond ((error? ast) (stderr "error:") (pretty-print ast (current-error-port)) #f) + ((eq? ast 'script) + #t) (else (map sh-exec ast) - ;;(map (cut local-eval <> (the-environment)) ast) ast)))) (define (unspecified? o) From 9623e014f04409ea9b2d7a70c142e9b4640e784c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 23:14:25 +0200 Subject: [PATCH 141/312] builtins: [: New command. * gash/builtins (bracket-command): New function. (%builtin-commands): Add it. --- gash/builtins.scm | 3 +++ 1 file changed, 3 insertions(+) diff --git a/gash/builtins.scm b/gash/builtins.scm index 15656d5..a2813f8 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -257,6 +257,8 @@ Options: (help? (option-ref options 'help #f)) (version? (option-ref options 'version #f)) (files (option-ref options '() '())) + (files (if (equal? (last files) "]") (drop-right files 1) + files)) (file (and (pair? files) (car files)))) (cond (help? (display "Usage: test [EXPRESSION] @@ -549,4 +551,5 @@ Options: ("type" . ,type-command) ("wc" . ,wc-command) ("which" . ,which-command) + ("[" . ,test-command) )) From d06572322133c81d0b12b9a87dc01ae9818bfde9 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 15 Jul 2018 10:58:02 +0200 Subject: [PATCH 142/312] parser: refactor, use `pipeline' instead of `expression'. --- gash/bournish-commands.scm | 1 - gash/builtins.scm | 98 ++++++++++++++++++++------------------ gash/guix-build-utils.scm | 11 ++++- gash/peg.scm | 21 +++----- gash/pipe.scm | 23 ++++----- 5 files changed, 78 insertions(+), 76 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index fc3d3b4..953e882 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -111,7 +111,6 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." (() (display-tabulated (scandir "."))) (args - (format (current-error-port) "hiero:args=~s\n" args) (let* ((option-spec '((all (single-char #\a)) (help) diff --git a/gash/builtins.scm b/gash/builtins.scm index a2813f8..0eced2f 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -34,7 +34,7 @@ #:use-module (gash guix-build-utils) #:use-module (gash io) #:use-module (gash job) - #:use-module (gash peg) ; pipeline + #:use-module (gash pipe) #:export ( %builtin-commands @@ -48,6 +48,7 @@ for substitution sh-exec + if-clause bg-command cd-command @@ -131,7 +132,7 @@ mostly works, pipes work, some redirections work. (let* ((option-spec '((help) (version))) - (options (getopt-long (cons "ls" args) option-spec)) + (options (getopt-long (cons "find" args) option-spec)) (help? (option-ref options 'help #f)) (version? (option-ref options 'version #f)) (files (option-ref options '() '())) @@ -164,7 +165,7 @@ Options: (help) (show (single-char #\v)) (version))) - (options (getopt-long (cons "ls" args) option-spec)) + (options (getopt-long (cons "command" args) option-spec)) (help? (option-ref options 'help #f)) (version? (option-ref options 'version #f)) (files (option-ref options '() '()))) @@ -206,7 +207,7 @@ Options: '((help) (canonical-file-name (single-char #\p)) (version))) - (options (getopt-long (cons "ls" args) option-spec)) + (options (getopt-long (cons "type" args) option-spec)) (help? (option-ref options 'help #f)) (version? (option-ref options 'version #f)) (files (option-ref options '() '()))) @@ -253,12 +254,10 @@ Options: (is-writable (single-char #\w)) (is-exeutable (single-char #\x)) (version))) - (options (getopt-long (cons "ls" args) option-spec)) + (options (getopt-long (cons "test" args) option-spec)) (help? (option-ref options 'help #f)) (version? (option-ref options 'version #f)) (files (option-ref options '() '())) - (files (if (equal? (last files) "]") (drop-right files 1) - files)) (file (and (pair? files) (car files)))) (cond (help? (display "Usage: test [EXPRESSION] @@ -284,11 +283,12 @@ Options: (left "==" right)) (equal? left right)) (expression - (let ((status (sh-exec `(pipeline (command ',expression))))) - (zero? status))))) + (pipeline (command expression))))) ((not (= (length files) 1)) (format (current-error-port) "test: too many files: ~a\n" files) 1) + ((option-ref options 'is-file #f) + (regular-file? file)) ((option-ref options 'is-directory #f) (directory-exists? file)) ((option-ref options 'exists #f) @@ -304,7 +304,22 @@ Options: (access? file W_OK)) ((option-ref options 'is-exeutable #f) (access? file X_OK)) - (else #f)))))) + (else + (error "gash: test: not supported" args))))))) + +(define bracket-command + (case-lambda + (() #f) + (args + (cond ((and (pair? args) (equal? (car args) "--help")) + (test-command "--help")) + ((and (pair? args) (equal? (car args) "--version")) + (test-command "--version")) + (else + (if (not (equal? (last args) "]")) (begin + (format (current-error-port) "gash: [: missing `]'\n") + #f) + (apply test-command (drop-right args 1)))))))) (define grep-command (case-lambda @@ -338,8 +353,8 @@ Options: (version? (format #t "grep (GASH) ~a\n" %version)) ((null? files) #t) (else - (let* ((pattern (warn 'pattern (car files))) - (files (warn 'files (cdr files))) + (let* ((pattern (car files)) + (files (cdr files)) (matches (append-map (cut grep pattern <>) files))) (define (display-match o) (let* ((s (grep-match-string o)) @@ -472,17 +487,26 @@ Options: (define (substitution . commands) (apply (@ (gash pipe) pipeline->string) (map cdr commands))) ;;HACK -(define (sh-exec ast) - (define (exec cmd) - (when (> %debug-level 0) - (format (current-error-port) "sh-exec:exec cmd=~s\n" cmd)) - (let* ((job (local-eval cmd (the-environment))) - (stati (cond ((job? job) (map status:exit-val (job-status job))) +(define-syntax if-clause + (lambda (x) + (syntax-case x () + ((_ expr then) + (with-syntax ((it (datum->syntax x 'it))) + #'(let ((it expr)) + (if (zero? it) then)))) + ((_ expr then else) + (with-syntax ((it (datum->syntax x 'it))) + #'(let ((it expr)) + (if (zero? it) then else))))))) + +(define (pipeline . commands) + (define (handle job) + (let* ((stati (cond ((job? job) (map status:exit-val (job-status job))) ((boolean? job) (list (if job 0 1))) ((number? job) (list job)) (else (list 0)))) - (status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0) - (car stati))) + (status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0) + (car stati))) (pipestatus (string-append "(" (string-join @@ -497,36 +521,18 @@ Options: (shell-opt? "errexit")) (exit status)) status)) - (when (> %debug-level 1) - (format (current-error-port) "sh-exec:exec ast=~s\n" ast)) - (match ast - ('script #t) ;; skip - (('pipeline commands ...) - (when (shell-opt? "xtrace") - (for-each - (lambda (o) - (match o - (('command command ...) - ;;(format (current-error-port) "+ ~a\n" (string-join command)) - ;; FIXME: side-effects done twice?! - ;; '(variable "$?"): not a string...hmm - (format (current-error-port) "+ ~a\n" (string-join (map (cut local-eval <> (the-environment)) command))) - ) - (_ (format (current-error-port) "FIXME trace:~s" o)))) - (reverse commands))) - (exec ast)) - (_ (for-each exec ast)))) - -(define (pipeline . commands) (when (> %debug-level 1) (format (current-error-port) "pijp: commands=~s\n" commands)) ;; FIXME: after running a builtin, we still end up here with the builtin's result ;; that should probably not happen, however, cater for it here for now (match commands - (((and (? boolean?) boolean)) (if boolean 0 1)) - (((and (? number?) number)) number) - (((? unspecified?)) 0) - (_ (apply (@ (gash pipe) pipeline) #t commands)))) + (((and (? boolean?) boolean)) + (handle boolean)) + (((and (? number?) number)) + (handle number)) + (((? unspecified?)) + (handle #t)) + (_ (handle (apply pipeline+ #t commands))))) (define %builtin-commands `( @@ -551,5 +557,5 @@ Options: ("type" . ,type-command) ("wc" . ,wc-command) ("which" . ,which-command) - ("[" . ,test-command) + ("[" . ,bracket-command) )) diff --git a/gash/guix-build-utils.scm b/gash/guix-build-utils.scm index dfeb773..a9c2639 100644 --- a/gash/guix-build-utils.scm +++ b/gash/guix-build-utils.scm @@ -44,6 +44,7 @@ directory-exists? executable-file? + regular-file? symbolic-link? )) @@ -67,9 +68,17 @@ (and s (not (zero? (logand (stat:mode s) #o100)))))) +(define (regular-file? file) + "Return #t if FILE is a regular file." + (let ((s (stat file #f))) + (and s + (eq? (stat:type s) 'regular)))) + (define (symbolic-link? file) "Return #t if FILE is a symbolic link (aka. \"symlink\".)" - (eq? (stat:type (lstat file)) 'symlink)) + (let ((s (lstat file))) + (and s + (eq? (stat:type s) 'symlink)))) (define (file-name-predicate regexp) "Return a predicate that returns true when passed a file name whose base diff --git a/gash/peg.scm b/gash/peg.scm index 0ba89a1..f7634ca 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -119,15 +119,14 @@ for-keyword < 'for' in-keyword < 'in' - for-clause <-- for-keyword sp+ name (ws+ in-keyword expression)? sp* sequential-sep do-group - expression <-- (sp+ word)+ + for-clause <-- for-keyword sp+ name (ws+ in-keyword pipeline)? sp* sequential-sep do-group do-keyword < 'do' done-keyword < 'done' do-group <- do-keyword ws* compound-list separator done-keyword if-keyword < 'if' fi-keyword < 'fi' - if-clause <-- if-keyword expression separator then-part elif-part* else-part? fi-keyword + if-clause <-- if-keyword pipeline separator then-part elif-part* else-part? fi-keyword then-keyword < 'then' then-part <-- then-keyword ws* compound-list separator elif-keyword < 'elif' @@ -144,11 +143,8 @@ filename <-- word name <-- identifier identifier <- [_a-zA-Z][_a-zA-Z0-9]* - word <- test / substitution / assignment / number / variable / delim / literal + word <- substitution / assignment / number / variable / delim / literal number <-- [0-9]+ - test <-- ltest expression rtest - ltest < '[ ' - rtest < ' ]' lsubst < '$(' rsubst < ')' tick < '`' @@ -156,7 +152,7 @@ assignment <-- name assign (substitution / word)* assign < '=' dollar <- '$' - literal <-- (!ltest !tick !dollar !pipe !semi !par !nl !sp .)+ + literal <-- (!tick !dollar !pipe !semi !par !nl !sp .)+ variable <-- dollar (dollar / '*' / '?' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) delim <- singlequotes / doublequotes / substitution sq < ['] @@ -201,7 +197,7 @@ ((eq? ast 'script) #t) (else - (map sh-exec ast) + (map (cut local-eval <> (the-environment)) ast) ast)))) (define (unspecified? o) @@ -217,8 +213,6 @@ (('pipeline h t) (pk `(pipeline ,(transform h) ,@(map transform t)))) (('command o ...) (let* ((command (map transform o)) (program (car command)) - ;; if [ 0 = 1 ] ... program = '(if ...) not a string - ;; this escape-builtin? is probably not deep enough? (escape-builtin? (and (string? program) (string-prefix? "\\" program))) (program (if escape-builtin? (string-drop program 1) program)) (command (cons program (cdr command)))) @@ -230,11 +224,10 @@ (('literal o) (transform o)) (('name o) o) (('number o) o) - (('expression o ...) `(expression ,@(map transform o))) (('assignment a b) `(lambda _ (assignment ,(transform a) ,(transform b)))) (('for-clause name expr do) `(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,(transform do)))) - (('if-clause expr then) `(if ,(transform expr) ,(transform then))) - (('if-clause expr then else) `(if ,(transform expr) ,(transform then) ,(transform else))) + (('if-clause expr then) `(if-clause ,(transform expr) ,(transform then))) + (('if-clause expr then else) `(if-clause ,(transform expr) ,(transform then) ,(transform else))) (('then-part o ...) `(begin ,@(map transform o))) (('else-part o ...) `(begin ,@(map transform o))) (_ ast))) diff --git a/gash/pipe.scm b/gash/pipe.scm index 1d2ad5a..947b876 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -13,7 +13,7 @@ #:use-module (gash job) #:use-module (gash io) - #:export (handle-error pipeline pipeline->string substitute)) + #:export (handle-error pipeline+ pipeline->string substitute)) (define (handle-error job error) (let ((status (wait job))) @@ -87,14 +87,9 @@ (map close w) r)))) -(define (pipeline fg? . commands) +(define (pipeline+ fg? . commands) (when (> %debug-level 0) - (format (current-error-port) "pipeline[~a]: COMMANDS: ~s\n" fg? commands)) - ;; (when (shell-opt? "xtrace") - ;; (for-each - ;; (lambda (o) - ;; (format (current-error-port) "+ ~a\n" (string-join o))) - ;; (reverse commands))) + (format (current-error-port) "pipeline+[~a]: COMMANDS: ~s\n" fg? commands)) (receive (r w) (pipe*) (move->fdes w 2) @@ -136,16 +131,16 @@ (define (pipeline->string . commands) (receive (job ports) - (apply pipeline #f commands) + (apply pipeline+ #f commands) (let ((output (read-string (car ports)))) (wait job) output))) -;;(pipeline #f '("head" "-c128" "/dev/urandom") '("tr" "-dc" "A-Z0-9") (lambda () (display (read-string)))) -;;(pipeline #f '("head" "-c128" "/dev/urandom") '("tr" "-dc" "A-Z0-9") '("cat")) -;;(pipeline #f (lambda () (display 'foo)) '("grep" "o") '("tr" "o" "e")) +;;(pipeline+ #f '("head" "-c128" "/dev/urandom") '("tr" "-dc" "A-Z0-9") (lambda () (display (read-string)))) +;;(pipeline+ #f '("head" "-c128" "/dev/urandom") '("tr" "-dc" "A-Z0-9") '("cat")) +;;(pipeline+ #f (lambda () (display 'foo)) '("grep" "o") '("tr" "o" "e")) -;; (pipeline #f +;; (pipeline+ #f ;; (lambda () (display "\nbin\nboot\nroot\nusr\nvar")) ;; '("tr" "u" "a") ;; (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string)))) @@ -153,7 +148,7 @@ ;; (lambda () (display (read-string)))) ;; (receive (job ports) -;; (pipeline #f +;; (pipeline+ #f ;; (lambda () ;; (display "foo") ;; (display "bar" (current-error-port))) From c32034d13d81010452158aea7ffbed29500af3b1 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 15 Jul 2018 13:37:19 +0200 Subject: [PATCH 143/312] command, builtin, glob, echo cleanup and fixes --- gash/builtins.scm | 49 +++++++++++++++++++++++------------------------ gash/gash.scm | 36 ---------------------------------- gash/peg.scm | 13 +------------ 3 files changed, 25 insertions(+), 73 deletions(-) diff --git a/gash/builtins.scm b/gash/builtins.scm index 0eced2f..a57e060 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -17,6 +17,7 @@ ;;; along with Gash. If not, see . (define-module (gash builtins) + #:use-module (ice-9 ftw) #:use-module (ice-9 getopt-long) #:use-module (ice-9 local-eval) #:use-module (ice-9 match) @@ -35,6 +36,7 @@ #:use-module (gash io) #:use-module (gash job) #:use-module (gash pipe) + #:use-module (gash util) #:export ( %builtin-commands @@ -74,8 +76,8 @@ (define (echo-command . args) (match args (() (newline)) - (("-n" args ...) (map display args)) - (_ (map display args) (newline)))) + (("-n" args ...) (display (string-join args))) + (_ (display (string-join args)) (newline)))) (define (bg-command . args) (match args @@ -419,25 +421,21 @@ Options: => (lambda (command) (if args - `(,apply ,command ',(map (cut local-eval <> (the-environment)) args)) - command))) + (apply command (map (cut local-eval <> (the-environment)) args)) + (command)))) (else #f))))) (define (command . args) (define (exec command) (cond ((procedure? command) command) - ((every string? command) (cut apply (compose status:exit-val system*) command)) - ;; not sure whether to do $?/PIPESTATUS here or in sh-exec ((every string? command) - (cut apply (compose (lambda (status) - ((compose (cut assignment "?" <>) number->string) status) - status) - (lambda (status) - (when (not (zero? status)) - (format (current-error-port) "*****gash: ~a: ~a" (car command) (strerror status))) - status) - status:exit-val - system*) command)) + (let* ((program (car command)) + (escape-builtin? (and (string? program) (string-prefix? "\\" program))) + (program (if escape-builtin? (string-drop program 1) program)) + (command (cons program (cdr command)))) + (or (builtin command #:prefer-builtin? (and %prefer-builtins? + (not escape-builtin?))) + (cut apply (compose status:exit-val system*) command)))) (else (lambda () #t)))) (exec (append-map glob args))) @@ -451,23 +449,24 @@ Options: (make-regexp (string-append "^" pattern "$")))) (define (glob-match regex path) ;; pattern path -> bool (regexp-match? (regexp-exec regex path))) - (define (glob- pattern paths) - (map (lambda (path) - (if (string-prefix? "./" path) (string-drop path 2) path)) - (append-map (lambda (path) - (map (cute string-append (if (string=? "/" path) "" path) "/" <>) + (define (glob- pattern file-names) + (map (lambda (file-name) + (if (string-prefix? "./" file-name) (string-drop file-name 2) file-name)) + (append-map (lambda (file-name) + (map (cut string-append (if (string=? "/" file-name) "" file-name) "/" <>) (filter (conjoin (negate (cut string-prefix? "." <>)) (cute glob-match (glob2regex pattern) <>)) - (or (scandir path) '())))) - paths))) + (or (scandir file-name) '())))) + file-names))) (cond ((not pattern) '("")) ((glob? pattern) (let ((absolute? (string-prefix? "/" pattern))) (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) - (paths (if absolute? '("/") '(".")))) + (file-names (if absolute? '("/") '(".")))) (if (null? patterns) - paths - (loop (cdr patterns) (glob- (car patterns) paths)))))) + file-names + (begin + (loop (cdr patterns) (glob- (car patterns) file-names))))))) (#t (list pattern)))) (define (singlequotes . o) diff --git a/gash/gash.scm b/gash/gash.scm index f85567c..683ebee 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -145,42 +145,6 @@ copyleft. (_ o)))) (map expand- o)) - -;; TODO: add braces -(define (glob pattern) ;; pattern -> list of path - - (define (glob? pattern) - (string-match "\\?|\\*" pattern)) - - (define (glob2regex pattern) - (let* ((pattern (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post)) - (pattern (regexp-substitute/global #f "\\?" pattern 'pre "." 'post)) - (pattern (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post))) - (make-regexp (string-append "^" pattern "$")))) - - (define (glob-match regex path) ;; pattern path -> bool - (regexp-match? (regexp-exec regex path))) - - (define (glob- pattern paths) - (map (lambda (path) - (if (string-prefix? "./" path) (string-drop path 2) path)) - (append-map (lambda (path) - (map (cute string-append (if (string=? "/" path) "" path) "/" <>) - (filter (conjoin (negate (cut string-prefix? "." <>)) - (cute glob-match (glob2regex pattern) <>)) - (or (scandir path) '())))) - paths))) - (cond - ((not pattern) '("")) - ((string-prefix? "$" pattern) (list (pk "get " pattern " => " (assoc-ref global-variables (string-drop pattern 1))))) ;; TODO: REMOVE ME - ((glob? pattern) (let ((absolute? (string-prefix? "/" pattern))) - (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) - (paths (if absolute? '("/") '(".")))) - (if (null? patterns) - paths - (loop (cdr patterns) (glob- (car patterns) paths)))))) - (#t (list pattern)))) - (define (DEAD-background ast) (match ast (('pipeline fg rest ...) `(pipeline #f ,@rest)) diff --git a/gash/peg.scm b/gash/peg.scm index f7634ca..e3839c5 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -1,5 +1,4 @@ (define-module (gash peg) - #:use-module (ice-9 ftw) #:use-module (ice-9 local-eval) #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) @@ -15,7 +14,6 @@ #:use-module (gash gash) #:use-module (gash io) #:use-module (gash job) - #:use-module (gash util) #:export ( parse @@ -211,16 +209,7 @@ (('substitution o) `(substitution ,@(transform o))) (('pipeline o) (pk `(pipeline ,(transform o)))) (('pipeline h t) (pk `(pipeline ,(transform h) ,@(map transform t)))) - (('command o ...) (let* ((command (map transform o)) - (program (car command)) - (escape-builtin? (and (string? program) (string-prefix? "\\" program))) - (program (if escape-builtin? (string-drop program 1) program)) - (command (cons program (cdr command)))) - (when (> %debug-level 1) - (format (current-error-port) "transform command=~s\n" command)) - (or (builtin command #:prefer-builtin? (and %prefer-builtins? - (not escape-builtin?))) - `(command ,@command)))) + (('command o ...) `(command ,@(map transform o))) (('literal o) (transform o)) (('name o) o) (('number o) o) From e6e03c6da206cf9986e92b3310edf0eaffc47711 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 15 Jul 2018 15:14:01 +0200 Subject: [PATCH 144/312] parser: handle substitution in for sequence. --- gash/builtins.scm | 25 +++++++++++++++++-------- gash/peg.scm | 20 +++++++++++++++----- 2 files changed, 32 insertions(+), 13 deletions(-) diff --git a/gash/builtins.scm b/gash/builtins.scm index a57e060..851dd14 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -46,10 +46,12 @@ glob singlequotes doublequotes - expression + sequence + splice for + split substitution - sh-exec + script if-clause bg-command @@ -475,16 +477,23 @@ Options: (define (doublequotes . o) (string-join (append-map glob o) "")) -(define (expression . args) - (append-map glob args)) +(define (sequence . args) + (apply append args)) -(define (for name expr body) +(define (script . o) + o) + +(define (for name sequence body) (for-each (lambda (value) (assignment name value) - (body)) (expr))) + (body)) + (sequence))) -(define (substitution . commands) - (apply (@ (gash pipe) pipeline->string) (map cdr commands))) ;;HACK +(define (split o) + ((compose string-tokenize string-trim-right) o)) + +(define-syntax-rule (substitution commands) + (split (with-output-to-string (lambda _ commands)))) (define-syntax if-clause (lambda (x) diff --git a/gash/peg.scm b/gash/peg.scm index e3839c5..9cbbb3d 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -117,7 +117,8 @@ for-keyword < 'for' in-keyword < 'in' - for-clause <-- for-keyword sp+ name (ws+ in-keyword pipeline)? sp* sequential-sep do-group + for-clause <-- for-keyword sp+ name (ws+ in-keyword sequence)? sp* sequential-sep do-group + sequence <-- (sp+ word)+ do-keyword < 'do' done-keyword < 'done' do-group <- do-keyword ws* compound-list separator done-keyword @@ -202,11 +203,10 @@ (eq? o *unspecified*)) (define (transform ast) - (when (> %debug-level 1) + (when (> %debug-level -1) (format (current-error-port) "transform ast=~s\n" ast)) (match ast - (('script o ...) (map transform o)) - (('substitution o) `(substitution ,@(transform o))) + (('script o ...) `(script ,@(map transform o))) (('pipeline o) (pk `(pipeline ,(transform o)))) (('pipeline h t) (pk `(pipeline ,(transform h) ,@(map transform t)))) (('command o ...) `(command ,@(map transform o))) @@ -214,7 +214,17 @@ (('name o) o) (('number o) o) (('assignment a b) `(lambda _ (assignment ,(transform a) ,(transform b)))) - (('for-clause name expr do) `(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,(transform do)))) + (('for-clause name expr do) + `(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,(transform do)))) + (('sequence o ...) + `(sequence ,@(fold-right (lambda (o r) + (cons + (match o + (('substitution x) (transform o)) + (_ `(list ,(transform o)))) + r)) + '() o))) + (('substitution o) `(substitution ,(transform o))) (('if-clause expr then) `(if-clause ,(transform expr) ,(transform then))) (('if-clause expr then else) `(if-clause ,(transform expr) ,(transform then) ,(transform else))) (('then-part o ...) `(begin ,@(map transform o))) From 85b90e8537e19bbf84abda3f6a6a55189bbea4aa Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 15 Jul 2018 16:30:54 +0200 Subject: [PATCH 145/312] job: disable backgrounding --- gash/job.scm | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/gash/job.scm b/gash/job.scm index 37f30f0..5220244 100644 --- a/gash/job.scm +++ b/gash/job.scm @@ -102,13 +102,15 @@ (let ((pgid (add-to-process-group job pid))) (set-job-pgid! job pgid) (stderr "job-add-process fg?=~a\n" fg?) - (when (and #f fg?) ;; FIXME + (when (and (isatty? (current-error-port)) + fg?) (tcsetpgrp (current-error-port) pgid)) (set-job-processes! job (cons (make-process pid command #f) (job-processes job))))) (define (job-setup-process fg? job) (when (isatty? (current-error-port)) - (when (and #f fg?) + (when (and (isatty? (current-error-port)) + fg?) (tcsetpgrp (current-error-port) (add-to-process-group job (getpid)))) (map (cut sigaction <> SIG_DFL) (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)))) @@ -116,7 +118,9 @@ (define (job-control-init) (when (isatty? (current-error-port)) (let ((pgid (getpgrp))) - (while (not (eqv? (tcgetpgrp (current-error-port)) pgid)) + (while (and #f ;; FIXME: make check backgrouds our tests + (isatty? (current-error-port)) + (not (eqv? (tcgetpgrp (current-error-port)) pgid))) (kill (- pgid) SIGTTIN))) ;; oops we are not in the foreground (map (cut sigaction <> SIG_IGN) (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU)) (sigaction SIGCHLD SIG_DFL) From 8f8ba68c54363c7926a924750c9c71d68094c8a1 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 15 Jul 2018 17:46:03 +0200 Subject: [PATCH 146/312] resurrect set -x --- gash/builtins.scm | 4 ++-- gash/environment.scm | 3 ++- gash/io.scm | 10 +++++++++- gash/peg.scm | 31 ++++++++++++++++++++++++++----- 4 files changed, 39 insertions(+), 9 deletions(-) diff --git a/gash/builtins.scm b/gash/builtins.scm index 851dd14..3f2200b 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -513,8 +513,8 @@ Options: ((boolean? job) (list (if job 0 1))) ((number? job) (list job)) (else (list 0)))) - (status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0) - (car stati))) + (status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0) + (car stati))) (pipestatus (string-append "(" (string-join diff --git a/gash/environment.scm b/gash/environment.scm index f1a32e7..a3dccfe 100644 --- a/gash/environment.scm +++ b/gash/environment.scm @@ -46,7 +46,8 @@ #t) (define (variable name) - (or (assoc-ref %global-variables (string-drop name 1)) "")) + (let ((name (if (string-prefix? "$" name) (string-drop name 1) name))) + (or (assoc-ref %global-variables name) ""))) (define (set-shell-opt! name set?) (let* ((shell-opts (variable "SHELLOPTS")) diff --git a/gash/io.scm b/gash/io.scm index e14eebe..d947369 100644 --- a/gash/io.scm +++ b/gash/io.scm @@ -1,8 +1,9 @@ (define-module (gash io) #:use-module (srfi srfi-1) + #:use-module (gash gash) - #:export (stdout stderr)) + #:export (pke stdout stderr)) (define (output port o) (map (lambda (o) (display o port)) o) @@ -16,3 +17,10 @@ (define (stderr . o) (output (current-error-port) o) (last o)) + +(define (pke . stuff) + (newline (current-error-port)) + (display ";;; " (current-error-port)) + (write stuff (current-error-port)) + (newline (current-error-port)) + (car (last-pair stuff))) diff --git a/gash/peg.scm b/gash/peg.scm index 9cbbb3d..1691f5c 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -188,9 +188,9 @@ (define (parse input) (let* ((pt (parse- input)) - (foo (pretty-print pt)) + (foo (when (> %debug-level 0) (pretty-print pt))) (ast (transform (keyword-flatten '(pipeline) pt))) - (foo (pretty-print ast))) + (foo (when (> %debug-level 0) (pretty-print ast)))) (cond ((error? ast) (stderr "error:") (pretty-print ast (current-error-port)) #f) ((eq? ast 'script) @@ -202,13 +202,34 @@ (define (unspecified? o) (eq? o *unspecified*)) +(define (trace commands) + (when (shell-opt? "xtrace") + (for-each + (lambda (o) + (match o + (('command (and command (? string?)) ...) + (format (current-error-port) "+ ~a\n" (string-join command))) + (_ (format (current-error-port) "+ ~s \n" o)))) + (reverse commands))) + commands) + (define (transform ast) - (when (> %debug-level -1) + (when (> %debug-level 1) (format (current-error-port) "transform ast=~s\n" ast)) (match ast (('script o ...) `(script ,@(map transform o))) - (('pipeline o) (pk `(pipeline ,(transform o)))) - (('pipeline h t) (pk `(pipeline ,(transform h) ,@(map transform t)))) + (('pipeline o) + (let ((commands (list (transform o)))) + (trace commands) + `(pipeline ,@commands))) + (('pipeline h (and t ('command _ ...) ...)) + (let ((commands (list (transform h) (transform t)))) + (trace commands) + `(pipeline ,@commands))) + (('pipeline h (and t (('command _ ...) ...))) + (let ((commands (cons (transform h) (map transform t)))) + (trace commands) + `(pipeline ,@commands))) (('command o ...) `(command ,@(map transform o))) (('literal o) (transform o)) (('name o) o) From bfc39b1a1813d805526c3a7fd32a8d8eeb7153fe Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 15 Jul 2018 18:18:39 +0200 Subject: [PATCH 147/312] test: implement -n, -z, !=. --- gash/builtins.scm | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/gash/builtins.scm b/gash/builtins.scm index 3f2200b..43d76be 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -257,35 +257,59 @@ Options: (is-readable (single-char #\r)) (is-writable (single-char #\w)) (is-exeutable (single-char #\x)) + (string-not-null (single-char #\n)) + (string-null (single-char #\z)) (version))) (options (getopt-long (cons "test" args) option-spec)) (help? (option-ref options 'help #f)) (version? (option-ref options 'version #f)) (files (option-ref options '() '())) - (file (and (pair? files) (car files)))) + (file (and (pair? files) (car files))) + (no-options? (and file + (= (length options) 1)))) (cond (help? (display "Usage: test [EXPRESSION] +Expression: + + STRING equivalent to -n STRING + + STRING1 = STRING2 + STRING1 == STRING2 + the strings are equal + + STRING1 != STRING2 + the strings are not equal + Options: -d FILE FILE exists and is a directory -e FILE FILE exists -f FILE FILE exists and is a regular file -h FILE FILE exists and is a symbolic link (same as -L) -L FILE FILE exists and is a symbolic link (same as -h) + -n STRING the length of STRING is nonzero -r FILE FILE exists and read permission is granted -s FILE FILE exists and has a size greater than zero -w FILE FILE exists and write permission is granted -x FILE FILE exists and execute (or search) permission is granted + -z STRING the length of STRING is zero --help display this help and exit --version display version information and exit ")) (version? (format #t "test (GASH) ~a\n" %version)) ((null? files) #f) + ((or (option-ref options 'n #f) + no-options?) + (not (string-null? file))) + ((option-ref options 'z #f) + (string-null? file)) ((and (= (length files) 3) (member (cadr files) '("=" "=="))) (match files ((or (left "=" right) (left "==" right)) (equal? left right)) + ((left "!=" right) + (not (equal? left right))) (expression (pipeline (command expression))))) ((not (= (length files) 1)) From e9a57a899cf9f76fc1738c3aa056c2e0e30e22ba Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 15 Jul 2018 18:39:17 +0200 Subject: [PATCH 148/312] more for-progress --- gash/peg.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/gash/peg.scm b/gash/peg.scm index 1691f5c..cd463d1 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -218,6 +218,7 @@ (format (current-error-port) "transform ast=~s\n" ast)) (match ast (('script o ...) `(script ,@(map transform o))) + ;; FIXME: how to get rid of PEG's gratuitous parentheses/heterogeneous grouping (('pipeline o) (let ((commands (list (transform o)))) (trace commands) @@ -230,13 +231,16 @@ (let ((commands (cons (transform h) (map transform t)))) (trace commands) `(pipeline ,@commands))) + ;; FIXME: ... + (((and h ('pipeline _ ...)) (and t (('pipeline _ ...) ...))) + (cons (transform h) (map transform t))) (('command o ...) `(command ,@(map transform o))) (('literal o) (transform o)) (('name o) o) (('number o) o) (('assignment a b) `(lambda _ (assignment ,(transform a) ,(transform b)))) - (('for-clause name expr do) - `(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,(transform do)))) + (('for-clause name expr body) + `(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,@(transform body)))) (('sequence o ...) `(sequence ,@(fold-right (lambda (o r) (cons From 83f20d1ff873e863c770acbf8e3117444ff0acfd Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 15 Jul 2018 20:06:19 +0200 Subject: [PATCH 149/312] flatten-fu --- gash/builtins.scm | 6 +++- gash/environment.scm | 3 ++ gash/gash.scm | 2 +- gash/peg.scm | 57 ++++++++++++++++++------------ test/08-assignment-susbtitution.sh | 3 ++ 5 files changed, 46 insertions(+), 25 deletions(-) create mode 100644 test/08-assignment-susbtitution.sh diff --git a/gash/builtins.scm b/gash/builtins.scm index 43d76be..087cdd5 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -53,6 +53,7 @@ substitution script if-clause + xtrace bg-command cd-command @@ -502,7 +503,7 @@ Options: (string-join (append-map glob o) "")) (define (sequence . args) - (apply append args)) + (append-map glob (apply append args))) (define (script . o) o) @@ -516,6 +517,9 @@ Options: (define (split o) ((compose string-tokenize string-trim-right) o)) +(define (xtrace o) + (o)) + (define-syntax-rule (substitution commands) (split (with-output-to-string (lambda _ commands)))) diff --git a/gash/environment.scm b/gash/environment.scm index a3dccfe..5dbcee1 100644 --- a/gash/environment.scm +++ b/gash/environment.scm @@ -20,6 +20,9 @@ (define-module (gash environment) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + + #:use-module (gash io) + #:export ( %global-variables assignment diff --git a/gash/gash.scm b/gash/gash.scm index 683ebee..05dba90 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -47,7 +47,7 @@ "" (string-split s #\newline))) (define (file-to-string filename) - (stdout "\n\n** " filename ":") + (format (current-error-port) "gash: reading: ~s\n" filename) ((compose read-string open-input-file) filename)) (define (string-to-ast string) diff --git a/gash/peg.scm b/gash/peg.scm index cd463d1..2b9ef71 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -22,7 +22,7 @@ (define (wrap-parser-for-users for-syntax parser accumsym s-syn) #`(lambda (str strlen pos) - (when (> (@ (gash gash) %debug-level) 1) + (when (> (@ (gash gash) %debug-level) 2) (format (current-error-port) "~a ~a : ~s\n" (make-string (- pos (or (string-rindex str #\newline 0 pos) 0)) #\space) '#,s-syn @@ -188,9 +188,11 @@ (define (parse input) (let* ((pt (parse- input)) - (foo (when (> %debug-level 0) (pretty-print pt))) - (ast (transform (keyword-flatten '(pipeline) pt))) - (foo (when (> %debug-level 0) (pretty-print ast)))) + (foo (when (> %debug-level 1) (display "tree:\n") (pretty-print pt))) + (flat (keyword-flatten '(and assignent command literal name or pipeline substitution) pt)) + (foo (when (> %debug-level 0) (display "flat:\n") (pretty-print flat))) + (ast (transform flat)) + (foo (when (> %debug-level 0) (display "ast:\n") (pretty-print ast)))) (cond ((error? ast) (stderr "error:") (pretty-print ast (current-error-port)) #f) ((eq? ast 'script) @@ -203,42 +205,51 @@ (eq? o *unspecified*)) (define (trace commands) - (when (shell-opt? "xtrace") - (for-each - (lambda (o) - (match o - (('command (and command (? string?)) ...) - (format (current-error-port) "+ ~a\n" (string-join command))) - (_ (format (current-error-port) "+ ~s \n" o)))) - (reverse commands))) - commands) + `(xtrace + ,(lambda _ + (when (shell-opt? "xtrace") + (for-each + (lambda (o) + (match o + (('command (and command (? string?)) ...) + (format (current-error-port) "+ ~a\n" (string-join command))) + (_ format (current-error-port) "+ ~s \n" o))) + (reverse commands)))))) (define (transform ast) (when (> %debug-level 1) (format (current-error-port) "transform ast=~s\n" ast)) (match ast (('script o ...) `(script ,@(map transform o))) + + ;; FIXME: how to get rid of PEG's gratuitous parentheses/heterogeneous grouping (('pipeline o) (let ((commands (list (transform o)))) - (trace commands) - `(pipeline ,@commands))) + `(pipeline ,@(cons (trace commands) commands)))) + (('pipeline h (and t ('command _ ...) ...)) (let ((commands (list (transform h) (transform t)))) - (trace commands) - `(pipeline ,@commands))) + `(pipeline ,@(cons (trace commands) commands)))) (('pipeline h (and t (('command _ ...) ...))) (let ((commands (cons (transform h) (map transform t)))) - (trace commands) - `(pipeline ,@commands))) - ;; FIXME: ... - (((and h ('pipeline _ ...)) (and t (('pipeline _ ...) ...))) - (cons (transform h) (map transform t))) + `(pipeline ,@(cons (trace commands) commands)))) + + ((and o (('pipeline _ ...) ...)) (map transform o)) + (('command o ...) `(command ,@(map transform o))) (('literal o) (transform o)) (('name o) o) (('number o) o) - (('assignment a b) `(lambda _ (assignment ,(transform a) ,(transform b)))) + + ;;(('assignment a b) `(assignment ,(transform a) ,(transform b))) + + ;; FIXME: flatten? + (('assignment a (and b ('literal _ ...))) `(assignment ,(transform a) ,(transform b))) + (('assignment a b) + `(assignment ,(transform a) ',(map transform b))) + + (('for-clause name expr body) `(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,@(transform body)))) (('sequence o ...) diff --git a/test/08-assignment-susbtitution.sh b/test/08-assignment-susbtitution.sh new file mode 100644 index 0000000..8792ff3 --- /dev/null +++ b/test/08-assignment-susbtitution.sh @@ -0,0 +1,3 @@ +f=test/test.sh +b=test/$(basename $f .sh) +echo b=$b From e7bfd347fa272d1725633ebdfda83624cf31f666 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 15 Jul 2018 20:47:09 +0200 Subject: [PATCH 150/312] checkpoint --- gash/peg.scm | 43 ++++++++++++++++++++++++++++--------------- 1 file changed, 28 insertions(+), 15 deletions(-) diff --git a/gash/peg.scm b/gash/peg.scm index 2b9ef71..41012dc 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -218,33 +218,46 @@ (define (transform ast) (when (> %debug-level 1) - (format (current-error-port) "transform ast=~s\n" ast)) + (pretty-print ast (current-error-port))) (match ast + ;; FIXME: flatten? + ((('pipeline _ ...) _ ...) + (map transform (keyword-flatten '(and assignent command literal name or pipeline substitution) ast))) + + ((('literal _ ...) _ ...) + (map transform (keyword-flatten '(and assignent command literal name or pipeline substitution) ast))) + + ((('assignent _ ...) _ ...) + (map transform (keyword-flatten '(and assignent command literal name or pipeline substitution) ast))) + + (('script o ...) `(script ,@(map transform o))) + ;; (('pipeline o) + ;; (let ((commands (list (transform o)))) + ;; `(pipeline ,@(cons (trace commands) commands)))) - ;; FIXME: how to get rid of PEG's gratuitous parentheses/heterogeneous grouping - (('pipeline o) - (let ((commands (list (transform o)))) + (('pipeline o ...) + (let ((commands (map transform o))) `(pipeline ,@(cons (trace commands) commands)))) - - (('pipeline h (and t ('command _ ...) ...)) - (let ((commands (list (transform h) (transform t)))) - `(pipeline ,@(cons (trace commands) commands)))) - (('pipeline h (and t (('command _ ...) ...))) - (let ((commands (cons (transform h) (map transform t)))) - `(pipeline ,@(cons (trace commands) commands)))) - - ((and o (('pipeline _ ...) ...)) (map transform o)) + ;; (('pipeline h (and t ('command _ ...) ...)) + ;; (let ((commands (list (transform h) (transform t)))) + ;; `(pipeline ,@(cons (trace commands) commands)))) + ;; (('pipeline h (and t (('command _ ...) ...))) + ;; (let ((commands (cons (transform h) (map transform t)))) + ;; `(pipeline ,@(cons (trace commands) commands)))) + + ;;((and o (('pipeline _ ...) ...)) (map transform o)) + + (('command o ...) `(command ,@(map transform o))) (('literal o) (transform o)) (('name o) o) (('number o) o) - ;;(('assignment a b) `(assignment ,(transform a) ,(transform b))) + ;;(('assignment a b) `(assignment ,(transform a) ',(transform b))) - ;; FIXME: flatten? (('assignment a (and b ('literal _ ...))) `(assignment ,(transform a) ,(transform b))) (('assignment a b) `(assignment ,(transform a) ',(map transform b))) From cbd13fdc884c1d46bc7622be0faf68e65680adc5 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 15 Jul 2018 20:49:52 +0200 Subject: [PATCH 151/312] checkpoint --- gash/peg.scm | 22 +--------------------- 1 file changed, 1 insertion(+), 21 deletions(-) diff --git a/gash/peg.scm b/gash/peg.scm index 41012dc..13d9048 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -230,38 +230,18 @@ ((('assignent _ ...) _ ...) (map transform (keyword-flatten '(and assignent command literal name or pipeline substitution) ast))) - (('script o ...) `(script ,@(map transform o))) - ;; (('pipeline o) - ;; (let ((commands (list (transform o)))) - ;; `(pipeline ,@(cons (trace commands) commands)))) - (('pipeline o ...) (let ((commands (map transform o))) `(pipeline ,@(cons (trace commands) commands)))) - ;; (('pipeline h (and t ('command _ ...) ...)) - ;; (let ((commands (list (transform h) (transform t)))) - ;; `(pipeline ,@(cons (trace commands) commands)))) - ;; (('pipeline h (and t (('command _ ...) ...))) - ;; (let ((commands (cons (transform h) (map transform t)))) - ;; `(pipeline ,@(cons (trace commands) commands)))) - - ;;((and o (('pipeline _ ...) ...)) (map transform o)) - - (('command o ...) `(command ,@(map transform o))) (('literal o) (transform o)) (('name o) o) (('number o) o) - ;;(('assignment a b) `(assignment ,(transform a) ',(transform b))) - - (('assignment a (and b ('literal _ ...))) `(assignment ,(transform a) ,(transform b))) - (('assignment a b) - `(assignment ,(transform a) ',(map transform b))) - + (('assignment a b) `(assignment ,(transform a) ',(transform b))) (('for-clause name expr body) `(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,@(transform body)))) From 1f5c82ecaed68f908e2c281a8889aaf897ffdb62 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 15 Jul 2018 21:35:42 +0200 Subject: [PATCH 152/312] word! test/if.sh, test/assign.sh --- test/assign.sh | 6 ++++++ test/if.sh | 3 +++ 2 files changed, 9 insertions(+) create mode 100644 test/assign.sh create mode 100644 test/if.sh diff --git a/test/assign.sh b/test/assign.sh new file mode 100644 index 0000000..db66f4f --- /dev/null +++ b/test/assign.sh @@ -0,0 +1,6 @@ + +ALLOCA='' +extras=' gettext.o' +REMOTE='stub' +objs="ar.o arscan.o commands.o dir.o expand.o file.o function.o getopt.o implicit.o job.o main.o misc.o read.o remake.o rule.o signame.o variable.o vpath.o default.o version.o getopt1.o remote-${REMOTE}.o ${extras} ${ALLOCA}" +#objs="remote-${REMOTE}.o" diff --git a/test/if.sh b/test/if.sh new file mode 100644 index 0000000..7532af5 --- /dev/null +++ b/test/if.sh @@ -0,0 +1,3 @@ +if [ x"$y" != x ]; then + echo "boo" +fi From 24c35cc5d9a9c7aff217b3a7e6ec101a690c43f3 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 15 Jul 2018 21:44:15 +0200 Subject: [PATCH 153/312] checkpoint --- gash/peg.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/gash/peg.scm b/gash/peg.scm index 13d9048..56fdda4 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -142,7 +142,8 @@ filename <-- word name <-- identifier identifier <- [_a-zA-Z][_a-zA-Z0-9]* - word <- substitution / assignment / number / variable / delim / literal + oldword <- substitution / assignment / number / variable / delim / literal + word <-- assignment / delim / (substitution / number / variable / literal)+ number <-- [0-9]+ lsubst < '$(' rsubst < ')' @@ -258,4 +259,6 @@ (('if-clause expr then else) `(if-clause ,(transform expr) ,(transform then) ,(transform else))) (('then-part o ...) `(begin ,@(map transform o))) (('else-part o ...) `(begin ,@(map transform o))) + (('word o) (transform o)) + (('word o ...) `(string-append ,@(map transform o))) (_ ast))) From 6468b04791982ad53c67827ac840dc9dc6b9fbb7 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 15 Jul 2018 23:01:52 +0200 Subject: [PATCH 154/312] refactor WORD...bummer: word-for-test-assign-sh word-for-test-if-sh --- bin/gash.in | 2 +- gash/builtins.scm | 13 ++++++++-- gash/peg.scm | 62 ++++++++++++++++++++++++++++++++++------------- test/assign.sh | 4 --- 4 files changed, 57 insertions(+), 24 deletions(-) diff --git a/bin/gash.in b/bin/gash.in index 9e7f52c..672d98f 100644 --- a/bin/gash.in +++ b/bin/gash.in @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -exec ${GUILE-guile} -L $(pwd)/bin -L $(pwd) -C $(pwd)/bin -C $(pwd) --no-auto-compile -e '(gash)' -s $0 "$@" +exec ${GUILE-guile} -L $(dirname $0) -L $(dirname $(dirname $0)) -C $(dirname $0) -C $(dirname $(dirname $0)) --no-auto-compile -e '(gash)' -s $0 "$@" !# (define-module (gash) #:export (main)) diff --git a/gash/builtins.scm b/gash/builtins.scm index 087cdd5..b1f0bc5 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -54,6 +54,7 @@ script if-clause xtrace + word bg-command cd-command @@ -503,7 +504,10 @@ Options: (string-join (append-map glob o) "")) (define (sequence . args) - (append-map glob (apply append args))) + (pke 'sequence (append-map glob (apply append args))) + ;;(pke 'sequence (map glob (pke 'apply-append (apply append (pke 'seq-args: args))))) + ;;(list (apply append args)) + ) (define (script . o) o) @@ -520,8 +524,13 @@ Options: (define (xtrace o) (o)) +(define (word . o) + (apply string-append o)) + (define-syntax-rule (substitution commands) - (split (with-output-to-string (lambda _ commands)))) + (let ((lst (pke 'split (split (pke 'string (with-output-to-string (lambda _ commands))))))) + (if (= (length lst) 1) (car lst) + lst))) (define-syntax if-clause (lambda (x) diff --git a/gash/peg.scm b/gash/peg.scm index 56fdda4..0dadd62 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -143,7 +143,13 @@ name <-- identifier identifier <- [_a-zA-Z][_a-zA-Z0-9]* oldword <- substitution / assignment / number / variable / delim / literal - word <-- assignment / delim / (substitution / number / variable / literal)+ + + word-for-test-assign-sh <-- assignment / (delim / number / variable / literal)+ + word-for-test-if-sh <-- assignment / delim / (number / variable / literal)+ + + word <-- assignment / (delim / number / variable / literal)+ + + number <-- [0-9]+ lsubst < '$(' rsubst < ')' @@ -187,10 +193,12 @@ (format (current-error-port) "parse error: no match\n") #f))))) +(define (flatten o) + (keyword-flatten '(and assignent command doublequotes for-clause literal name or pipeline singlequotes substitution word) o)) (define (parse input) (let* ((pt (parse- input)) (foo (when (> %debug-level 1) (display "tree:\n") (pretty-print pt))) - (flat (keyword-flatten '(and assignent command literal name or pipeline substitution) pt)) + (flat (flatten pt)) (foo (when (> %debug-level 0) (display "flat:\n") (pretty-print flat))) (ast (transform flat)) (foo (when (> %debug-level 0) (display "ast:\n") (pretty-print ast)))) @@ -222,43 +230,63 @@ (pretty-print ast (current-error-port))) (match ast ;; FIXME: flatten? - ((('pipeline _ ...) _ ...) - (map transform (keyword-flatten '(and assignent command literal name or pipeline substitution) ast))) - ((('literal _ ...) _ ...) - (map transform (keyword-flatten '(and assignent command literal name or pipeline substitution) ast))) + ((('assignent _ ...) _ ...) (map transform (flatten ast))) + ((('command _ ...) _ ...) (map transform (flatten ast))) + ((('doublequotes _ ...) _ ...) (map transform (flatten ast))) + ((('for-clause _ ...) _ ...) (map transform (flatten ast))) + ((('literal _ ...) _ ...) (map transform (flatten ast))) + ((('pipeline _ ...) _ ...) (map transform (flatten ast))) + ((('singlequotes _ ...) _ ...) (map transform (flatten ast))) + ((('word _ ...) _ ...) (map transform (flatten ast))) - ((('assignent _ ...) _ ...) - (map transform (keyword-flatten '(and assignent command literal name or pipeline substitution) ast))) (('script o ...) `(script ,@(map transform o))) (('pipeline o ...) (let ((commands (map transform o))) - `(pipeline ,@(cons (trace commands) commands)))) + `(pipeline ,@(cons (trace commands) commands)))) (('command o ...) `(command ,@(map transform o))) (('literal o) (transform o)) (('name o) o) (('number o) o) - (('assignment a b) `(assignment ,(transform a) ',(transform b))) + ;;(('assignment a b) `(assignment ,(transform a) ',(transform b))) + ;; FIXME: to quote or not? + (('assignment a b) `(assignment ,(transform a) ,(transform b))) + ;; (('assignment a (and b ('literal _ ...))) `(assignment ,(transform a) ,(transform b))) + ;; (('assignment a b) + ;; `(assignment ,(transform a) ,(map transform b))) + + + (('for-clause name expr (and body ('pipeline _ ...))) + `(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,(transform body)))) (('for-clause name expr body) - `(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,@(transform body)))) + `(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,@(map transform body)))) + (('sequence o) + `(sequence ,@(fold-right (lambda (o r) + (cons + (match o + (('substitution x) (transform o)) + (_ `(list ,(transform o)))) + r)) + '() o))) (('sequence o ...) `(sequence ,@(fold-right (lambda (o r) - (cons - (match o - (('substitution x) (transform o)) - (_ `(list ,(transform o)))) - r)) - '() o))) + (cons + (match o + (('substitution x) (transform o)) + (_ `(list ,(transform o)))) + r)) + '() o))) (('substitution o) `(substitution ,(transform o))) (('if-clause expr then) `(if-clause ,(transform expr) ,(transform then))) (('if-clause expr then else) `(if-clause ,(transform expr) ,(transform then) ,(transform else))) (('then-part o ...) `(begin ,@(map transform o))) (('else-part o ...) `(begin ,@(map transform o))) + (('word 'singlequotes) "") (('word o) (transform o)) (('word o ...) `(string-append ,@(map transform o))) (_ ast))) diff --git a/test/assign.sh b/test/assign.sh index db66f4f..c960245 100644 --- a/test/assign.sh +++ b/test/assign.sh @@ -1,6 +1,2 @@ ALLOCA='' -extras=' gettext.o' -REMOTE='stub' -objs="ar.o arscan.o commands.o dir.o expand.o file.o function.o getopt.o implicit.o job.o main.o misc.o read.o remake.o rule.o signame.o variable.o vpath.o default.o version.o getopt1.o remote-${REMOTE}.o ${extras} ${ALLOCA}" -#objs="remote-${REMOTE}.o" From 292fbc5ecbb48810e5ee3cab8fae9b2fa666d77a Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 15 Jul 2018 23:26:55 +0200 Subject: [PATCH 155/312] test/if.sh, test/if2.sh -- weird --- gash/peg.scm | 2 +- test/assign2.sh | 1 + test/if.sh | 2 +- test/if2.sh | 3 +++ 4 files changed, 6 insertions(+), 2 deletions(-) create mode 100644 test/assign2.sh create mode 100644 test/if2.sh diff --git a/gash/peg.scm b/gash/peg.scm index 0dadd62..af9228a 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -145,7 +145,7 @@ oldword <- substitution / assignment / number / variable / delim / literal word-for-test-assign-sh <-- assignment / (delim / number / variable / literal)+ - word-for-test-if-sh <-- assignment / delim / (number / variable / literal)+ + word-for-test-if2-sh <-- assignment / delim / (number / variable / literal)+ word <-- assignment / (delim / number / variable / literal)+ diff --git a/test/assign2.sh b/test/assign2.sh new file mode 100644 index 0000000..190d2de --- /dev/null +++ b/test/assign2.sh @@ -0,0 +1 @@ +defines="-DALIASPATH=\"${aliaspath}\" -" diff --git a/test/if.sh b/test/if.sh index 7532af5..b0e4dd0 100644 --- a/test/if.sh +++ b/test/if.sh @@ -1,3 +1,3 @@ if [ x"$y" != x ]; then - echo "boo" + echo boo fi diff --git a/test/if2.sh b/test/if2.sh new file mode 100644 index 0000000..7532af5 --- /dev/null +++ b/test/if2.sh @@ -0,0 +1,3 @@ +if [ x"$y" != x ]; then + echo "boo" +fi From 9462aaa1632d3c0b12dc04301b1bcf26afcf9a4c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 16 Jul 2018 07:48:02 +0200 Subject: [PATCH 156/312] checkpoint --- gash/gash.scm | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/gash/gash.scm b/gash/gash.scm index 05dba90..585d2dc 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -46,19 +46,21 @@ (string-append prev sep next))) "" (string-split s #\newline))) -(define (file-to-string filename) - (format (current-error-port) "gash: reading: ~s\n" filename) - ((compose read-string open-input-file) filename)) +(define (file-to-string file-name) + (format (current-error-port) "gash: reading: ~s\n" file-name) + (with-input-from-file file-name read-string)) (define (string-to-ast string) ((compose parse remove-escaped-newlines remove-shell-comments) string)) -(define (file-to-ast filename) - ((compose string-to-ast file-to-string) filename)) +(define (file-to-ast file-name) + ((compose string-to-ast file-to-string) file-name)) (define (display-help) (display "\ -gash [options] +Usage: gash [OPTION]... [FILE]... + +Options: -c, --command=STRING Evaluate STRING and exit -e, --errexit Exit upon error -d, --debug Enable PEG tracing @@ -254,7 +256,7 @@ copyleft. path))) -(define (filename-completion text continue?) +(define (file-name-completion text continue?) (if continue? (next->file-completion) (let* ((dir (slash (if (isdir? text) text (dirname text)))) @@ -285,4 +287,4 @@ copyleft. (next->binary-completion))) (define (completion text continue?) - (or (filename-completion text continue?) (search-binary-in-path-completion text continue?))) + (or (file-name-completion text continue?) (search-binary-in-path-completion text continue?))) From 0f5b538c3ab71664f8eaa2d394f1e4162c50d5fc Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 16 Jul 2018 08:41:10 +0200 Subject: [PATCH 157/312] geesh: initial integration. GUILE_LOAD_PATH=$HOME/src/geesh:$GUILE_LOAD_PATH GUILE_LOAD_COMPILED_PATH=$HOME/src/geesh:$GUILE_LOAD_COMPILED_PATH bin/gash --parse -c 'echo boo | sed s,o,O, | grep .' bin/gash --geesh --parse -c 'echo boo | sed s,o,O, | grep .' --- INSTALL | 30 + build-aux/build-guile.sh | 7 +- configure | 9 + gash/bournish-commands.scm | 253 +++++-- gash/builtins.scm | 621 ++++++------------ gash/environment.scm | 4 + gash/gash.scm | 144 +--- gash/geesh.scm | 127 ++++ gash/guix-build-utils.scm | 36 +- gash/job.scm | 12 +- gash/peg.scm | 141 +++- gash/script.scm | 251 +++++++ gash/util.scm | 14 +- test.sh | 5 +- ...05-assignment-doublequoted-doublequotes.sh | 5 + test/06-assignment-singlequote.sh | 1 + test/07-assignment-double-quote.sh | 1 + test/08-assignment-variable-word.sh | 1 + test/09-compound-word.sh | 2 + test/0a-assign-substitute.sh | 2 + test/0b-command-compound-word.sh | 3 + test/10-if.sh | 4 + test/11-if-false.sh | 4 + ...ution.sh => 30-assignment-substitution.sh} | 0 test/30-eval.sh | 1 + test/31-eval-echo-variable.sh | 2 + test/32-for-substitute.sh | 3 + test/35-assignment-eval-echo.sh | 1 + test/assign2.sh | 2 + test/for-split-sequence.sh | 5 + test/for.sh | 3 + test/if.sh | 3 - test/iohere.sh | 1 - 33 files changed, 1029 insertions(+), 669 deletions(-) create mode 100644 INSTALL create mode 100644 gash/geesh.scm create mode 100644 gash/script.scm create mode 100644 test/05-assignment-doublequoted-doublequotes.sh create mode 100644 test/06-assignment-singlequote.sh create mode 100644 test/07-assignment-double-quote.sh create mode 100644 test/08-assignment-variable-word.sh create mode 100644 test/09-compound-word.sh create mode 100644 test/0a-assign-substitute.sh create mode 100644 test/0b-command-compound-word.sh create mode 100644 test/10-if.sh create mode 100644 test/11-if-false.sh rename test/{08-assignment-susbtitution.sh => 30-assignment-substitution.sh} (100%) create mode 100644 test/30-eval.sh create mode 100644 test/31-eval-echo-variable.sh create mode 100644 test/32-for-substitute.sh create mode 100644 test/35-assignment-eval-echo.sh create mode 100644 test/for-split-sequence.sh create mode 100644 test/for.sh delete mode 100644 test/if.sh diff --git a/INSTALL b/INSTALL new file mode 100644 index 0000000..7835cdc --- /dev/null +++ b/INSTALL @@ -0,0 +1,30 @@ + -*- org -*- +Building and Installing Gash + +* Get it + git clone https://gitlab.com/rutger.van.beusekom/gash + +* Regular build +** Prerequisites +*** Guix + guix environment -l guix.scm + +*** Other GNU/Linux + - [[https://gitlab.com/samplet/geesh][geesh]], 0.1-rc is known to work. + - GNU Guile, version 2.2.3 or is known to work. + - GNU make, version 4.2 known to work. + - SH, /bin/sh, GNU Bash 4.3 is known to work. + - git, 2.10 is known to work. + +** Build it + ./configure + make + +** Check it + make check + +** Install it + make install + +* Guix it + guix package -f guix.scm diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 5748985..b41d1ca 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -27,6 +27,9 @@ export GUILE_AUTO_COMPILE export GUILE_LOAD_PATH export GUILE_LOAD_COMPILED_PATH +GUILE_LOAD_PATH=$HOME/src/geesh:$GUILE_LOAD_PATH +GUILE_LOAD_COMPILED_PATH=$HOME/src/geesh:$GUILE_LOAD_COMPILED_PATH + GUILE_LOAD_PATH=$(pwd):$GUILE_LOAD_PATH GUILE_LOAD_COMPILED_PATH=$(pwd):$GUILE_LOAD_COMPILED_PATH GUILE=${GUILE-$(command -v guile)} @@ -37,15 +40,17 @@ set -e SCM_FILES=" gash/bournish-commands.scm +gash/guix-build-utils.scm gash/builtins.scm gash/config.scm gash/environment.scm -gash/guix-build-utils.scm +gash/geesh.scm gash/gash.scm gash/io.scm gash/job.scm gash/peg.scm gash/pipe.scm +gash/script.scm gash/util.scm " diff --git a/configure b/configure index f23d4ca..35be694 100755 --- a/configure +++ b/configure @@ -18,6 +18,15 @@ GUILE_SITE_DIR=$PREFIX/share/guile/site/$GUILE_EFFECTIVE_VERSION GUILE_SITE_CCACHE_DIR=$PREFIX/lib/guile/$GUILE_EFFECTIVE_VERSION/site-ccache GUILE_EFFECTIVE_VERSION=$(guile -c '(display (effective-version))') MAKEINFO=$(command -v makeinfo) +GEESH_PREFIX=${GEESH_PREFIX-$HOME/src/geesh} +if [ -d $GEESH_PREFIX ]; then + GUILE_LOAD_PATH=$GEESH_PREFIX:$GUILE_LOAD_PATH + GUILE_LOAD_COMPILED_PATH=$GEESH_PREFIX:$GUILE_LOAD_COMPILED_PATH + if ! $GUILE -c '(use-modules (geesh parser)) (exit (defined? '"'"'read-sh-all))'; then + echo "your geesh is too old" + exit 1 + fi +fi sed \ -e s,@GUILE@,$GUILE,\ diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 953e882..b158e28 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -33,15 +33,19 @@ #:use-module (gash guix-build-utils) #:use-module (gash config) #:use-module (gash io) + #:use-module (gash util) + #:export ( - display-tabulated + %bournish-commands cat-command + display-tabulated + find-command + grep-command ls-command reboot-command rm-command wc-command which-command - wrap-command )) ;;; Commentary: @@ -105,24 +109,21 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." (module-define! (resolve-module '(ice-9 getopt-long)) 'short-opt-rx (make-regexp "^-([a-zA-Z0-9]+)(.*)"))) (else)) -(define ls-command-implementation +(define (ls-command-implementation . args) ;; Run-time support procedure. - (case-lambda - (() - (display-tabulated (scandir "."))) - (args - (let* ((option-spec - '((all (single-char #\a)) - (help) - (one-file-per-line (single-char #\1)) - (version))) - (options (getopt-long (cons "ls" args) option-spec)) - (all? (option-ref options 'all #f)) - (help? (option-ref options 'help #f)) - (one-file-per-line? (option-ref options 'one-file-per-line #f)) - (version? (option-ref options 'version #f)) - (files (option-ref options '() '()))) - (cond (help? (display "Usage: ls [OPTION]... [FILE]... + (lambda _ + (let* ((option-spec + '((all (single-char #\a)) + (help) + (one-file-per-line (single-char #\1)) + (version))) + (options (getopt-long (cons "ls" args) option-spec)) + (all? (option-ref options 'all #f)) + (help? (option-ref options 'help #f)) + (one-file-per-line? (option-ref options 'one-file-per-line #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (cond (help? (display "Usage: ls [OPTION]... [FILE]... Options: -a, --all do not ignore entries starting with . @@ -130,60 +131,62 @@ Options: --help display this help and exit --version display version information and exit ")) - (version? (format #t "ls (GASH) ~a\n" %version)) - (else - (let* ((files (if (null? files) (scandir ".") - (append-map (lambda (file) - (catch 'system-error - (lambda () - (match (stat:type (lstat file)) - ('directory - ;; Like GNU ls, list the contents of - ;; FILE rather than FILE itself. - (match (scandir file - (match-lambda - ((or "." "..") #f) - (_ #t))) - (#f - (list file)) - ((files ...) - (map (cut string-append file "/" <>) - files)))) - (_ - (list file)))) - (lambda args - (let ((errno (system-error-errno args))) - (format (current-error-port) "~a: ~a~%" - file (strerror errno)) - '())))) - files))) - (files (if all? files - (filter (negate (cut string-prefix? "." <>)) files)))) - (if one-file-per-line? (for-each stdout files) - (display-tabulated files))))))))) + (version? (format #t "ls (GASH) ~a\n" %version)) + (else + (let* ((files (if (null? files) (scandir ".") + (append-map (lambda (file) + (catch 'system-error + (lambda () + (match (stat:type (lstat file)) + ('directory + ;; Like GNU ls, list the contents of + ;; FILE rather than FILE itself. + (match (scandir file + (match-lambda + ((or "." "..") #f) + (_ #t))) + (#f + (list file)) + ((files ...) + (map (cut string-append file "/" <>) + files)))) + (_ + (list file)))) + (lambda args + (let ((errno (system-error-errno args))) + (format (current-error-port) "~a: ~a~%" + file (strerror errno)) + '())))) + files))) + (files (if all? files + (filter (negate (cut string-prefix? "." <>)) files)))) + (if one-file-per-line? (for-each stdout files) + (display-tabulated files)))))))) (define ls-command (wrap-command ls-command-implementation "ls")) (define (which-command program . rest) - (stdout (search-path (executable-path) program))) + (lambda _ + (stdout (search-path (executable-path) program)))) (define (cat-command-implementation . args) - (fold (lambda (file p) - (if (string=? file "-") (dump-port (current-input-port) (current-output-port)) - (call-with-input-file file - (lambda (port) - (dump-port port (current-output-port)))))) - 0 args)) + (lambda _ + (fold (lambda (file p) + (if (string=? file "-") (dump-port (current-input-port) (current-output-port)) + (call-with-input-file file + (lambda (port) + (dump-port port (current-output-port)))))) + 0 args))) (define cat-command (wrap-command cat-command-implementation "cat")) (define (rm-command-implementation . args) - "Emit code for the 'rm' command." - (cond ((member "-r" args) - (for-each delete-file-recursively - (apply delete (cons "-r" args)))) - (else - (for-each delete-file args)))) + (lambda _ + (cond ((member "-r" args) + (for-each delete-file-recursively + (apply delete (cons "-r" args)))) + (else + (for-each delete-file args))))) (define rm-command (wrap-command rm-command-implementation "rm")) @@ -235,12 +238,13 @@ Options: (define (wc-command . args) "Emit code for the 'wc' command." - (cond ((member "-l" args) - (apply wc-l-command-implementation (delete "-l" args))) - ((member "-c" args) - (apply wc-c-command-implementation (delete "-c" args))) - (else - (apply wc-command-implementation args)))) + (lambda _ + (cond ((member "-l" args) + (apply wc-l-command-implementation (delete "-l" args))) + ((member "-c" args) + (apply wc-c-command-implementation (delete "-c" args))) + (else + (apply wc-command-implementation args))))) (define (reboot-command . args) "Emit code for 'reboot'." @@ -259,3 +263,114 @@ Options: (match (getenv "PATH") (#f '()) (str (string-tokenize str %not-colon)))) + +(define (cp-command-implementation source dest . rest) + (lambda _ (copy-file source dest))) + +(define cp-command (wrap-command cp-command-implementation "cp")) + +(define (find-command-implementation . args) + ;; Run-time support procedure. + (lambda _ + (let* ((option-spec + '((help) + (version))) + (options (getopt-long (cons "find" args) option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '())) + (files (if (null? files) '(".") files)) + (file (car files))) + (when (> (length files) 1) + (format (current-error-port) "find: too many FILEs: ~s\n" files) + (error "find failed")) + ;; TODO: find [OPTION]... [FILE]... [EXPRESSION]... + ;; and options: esp: -x, -L + (cond (help? (display "Usage: find [OPTION]... [FILE] + +Options: + --help display this help and exit + --version display version information and exit +")) + (version? (format #t "find (GASH) ~a\n" %version)) + (else + (let* ((files (find-files file #:directories? #t #:fail-on-error? #t))) + (for-each stdout files))))))) + +(define find-command (wrap-command find-command-implementation "find")) + +(define (grep-command . args) + (lambda _ + (let* ((option-spec + '((help) + (line-number (single-char #\n)) + (files-with-matches (single-char #\l)) + (files-without-match (single-char #\L)) + (with-file-name (single-char #\H)) + (no-file-name (single-char #\h)) + (only-matching (single-char #\o)) + (version (single-char #\V)))) + (options (getopt-long (cons "ls" args) option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (cond (help? (display "Usage: grep [OPTION]... PATTERN [FILE]... + +Options: + --help display this help and exit + -h, --no-filename suppress the file name prefix on output + -H, --with-filename print file name with output lines + -l, --files-with-matches print only names of FILEs with selected lines + -L, --files-without-match print only names of FILEs with no selected lines + -n, --line-number print line number with output lines + -o, --only-matching show only the part of a line matching PATTERN + -V, --version display version information and exit +")) + (version? (format #t "grep (GASH) ~a\n" %version)) + ((null? files) #t) + (else + (let* ((pattern (car files)) + (files (if (pair? (cdr files)) (cdr files) + (list "-"))) + (matches (append-map (cut grep pattern <>) files))) + (define (display-match o) + (let* ((s (grep-match-string o)) + (s (if (option-ref options 'only-matching #f) + (substring s (grep-match-column o) (grep-match-end-column o)) + s)) + (s (if (option-ref options 'line-number #f) + (string-append (number->string (grep-match-line o)) ":" s) + s)) + (s (if (option-ref options 'with-file-name #f) + (string-append (grep-match-file-name o) ":" s) + s))) + (stdout s))) + (define (files-with-matches) + (delete-duplicates (map grep-match-file-name matches))) + (cond ((option-ref options 'files-with-matches #f) + (let ((result (files-with-matches))) + (and (pair? result) + (for-each stdout result) + 0))) + ((option-ref options 'files-without-match #f) + (let* ((result (files-with-matches)) + (result (filter (negate (cut member <> result)) files))) + (and (pair? result) + (for-each stdout result) + 0))) + (else + (and (pair? matches) + (for-each display-match matches) + 0))))))))) + +(define %bournish-commands + `( + ("cat" . ,cat-command) + ("cp" . ,cp-command) + ("find" . ,find-command) + ("grep" . ,grep-command) + ("ls" . ,ls-command) + ("reboot" . ,reboot-command) + ("wc" . ,wc-command) + ("which" . ,which-command) + )) diff --git a/gash/builtins.scm b/gash/builtins.scm index b1f0bc5..44c740e 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -28,60 +28,54 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) - #:use-module (gash bournish-commands) #:use-module (gash config) + #:use-module (gash gash) ; %prefer-builtins? + #:use-module (gash bournish-commands) #:use-module (gash environment) - #:use-module (gash gash) #:use-module (gash guix-build-utils) #:use-module (gash io) #:use-module (gash job) #:use-module (gash pipe) + #:use-module (gash script) #:use-module (gash util) #:export ( %builtin-commands - builtin - pipeline - command - glob - singlequotes - doublequotes - sequence - splice - for - split - substitution - script - if-clause - xtrace - word + PATH-search-path + trace bg-command cd-command echo-command + eval-command exit-command fg-command - find-command help-command + jobs-command pwd-command set-command )) +(define (PATH-search-path program) + (search-path (string-split (getenv "PATH") #\:) program)) + (define (cd-command . args) (match args (() (cd-command (getenv "HOME"))) ((dir) - (assignment "OLDPWD" (getcwd)) - (if (string=? dir "-") (chdir (variable "OLDPWD")) - (chdir dir))) + (let ((old (variable "OLDPWD"))) + (assignment "OLDPWD" (getcwd)) + (if (string=? dir "-") (chdir old) + (chdir dir)))) ((args ...) (format (current-error-port) "cd: too many arguments: ~a\n" (string-join args))))) (define (echo-command . args) - (match args - (() (newline)) - (("-n" args ...) (display (string-join args))) - (_ (display (string-join args)) (newline)))) + (lambda _ + (match args + (() (newline)) + (("-n" args ...) (display (string-join args))) + (_ (display (string-join args)) (newline))))) (define (bg-command . args) (match args @@ -93,18 +87,34 @@ (() (fg 1)) ((job x ...) (fg (string->number (car job)))))) -(define pwd-command (lambda _ (stdout (getcwd)))) +(define (jobs-command) + (format (current-error-port) "jobs: ~s\n" job-table) + (for-each (lambda (job) (display-job job)) (reverse job-table))) + +(define (pwd-command . _) + (lambda _ (stdout (getcwd)))) (define (set-command . args) ;; TODO export; env vs set (define (display-var o) (format #t "~a=~a\n" (car o) (cdr o))) (match args - (() (for-each display-var global-variables)) + (() (lambda _ (for-each display-var %global-variables))) (("-e") (set-shell-opt! "errexit" #t)) (("+e") (set-shell-opt! "errexit" #f)) (("-x") (set-shell-opt! "xtrace" #t)) (("+x") (set-shell-opt! "xtrace" #f)))) +(define (eval-command . args) + (lambda _ + (match args + (() #t) + ((args ...) + (let ((ast (parse-string (string-join args)))) + ;;(ignore-error (run ast)) + (run ast) + (assignment "?" "0") + #t))))) + (define (exit-command . args) (match args (() (exit 0)) @@ -114,68 +124,34 @@ (format (current-error-port) "exit: too many arguments: ~a\n" (string-join args))))) (define (help-command . _) - (display "\ + (lambda _ + (display "\ Hello, this is GASH, Guile As SHell. GASH is work in progress; many language constructs work, globbing mostly works, pipes work, some redirections work. ") - (when (or %prefer-builtins? (not (PATH-search-path "ls"))) - (display "\nIt features the following, somewhat naive builtin commands\n") - (display-tabulated (map car %builtin-commands)))) - -(define (cp-command-implementation source dest . rest) - (copy-file source dest)) - -(define cp-command (wrap-command cp-command-implementation "cp")) - -(define find-command-implementation - ;; Run-time support procedure. - (case-lambda - (() - (find-command-implementation ".")) - (args - (let* ((option-spec - '((help) - (version))) - (options (getopt-long (cons "find" args) option-spec)) - (help? (option-ref options 'help #f)) - (version? (option-ref options 'version #f)) - (files (option-ref options '() '())) - (files (if (null? files) '(".") files)) - (file (car files))) - (when (> (length files) 1) - (format (current-error-port) "find: too many FILEs: ~s\n" files) - (error "find failed")) - ;; TODO: find [OPTION]... [FILE]... [EXPRESSION]... - ;; and options: esp: -x, -L - (cond (help? (display "Usage: find [OPTION]... [FILE] - -Options: - --help display this help and exit - --version display version information and exit -")) - (version? (format #t "find (GASH) ~a\n" %version)) - (else - (let* ((files (find-files file #:directories? #t #:fail-on-error? #t))) - (for-each stdout files)))))))) - -(define find-command (wrap-command find-command-implementation "find")) + (display "\nIt has these builtin commands:\n") + (display-tabulated (map car %builtin-commands)) + (when (or %prefer-builtins? (not (PATH-search-path "ls"))) + (display "\nand features the following, somewhat naive, bournish commands:\n") + (display-tabulated (map car %bournish-commands))))) (define command-command (case-lambda (() #t) (args - (let* ((option-spec - '((describe (single-char #\V)) - (help) - (show (single-char #\v)) - (version))) - (options (getopt-long (cons "command" args) option-spec)) - (help? (option-ref options 'help #f)) - (version? (option-ref options 'version #f)) - (files (option-ref options '() '()))) - (cond (help? (display "Usage: command [OPTION]... [COMMAND [ARG]...] + (lambda _ + (let* ((option-spec + '((describe (single-char #\V)) + (help) + (show (single-char #\v)) + (version))) + (options (getopt-long (cons "command" args) option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (cond (help? (display "Usage: command [OPTION]... [COMMAND [ARG]...] Options: --help display this help and exit @@ -183,93 +159,95 @@ Options: -v display a description of COMMAND similar to the `type' builtin -V display a more verbose description of COMMAND ")) - (version? (format #t "command (GASH) ~a\n" %version)) - ((null? files) #t) - ((option-ref options 'describe #f) - (let* ((command (car files)) - (builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?))) - (cond (builtin (format #t "~a is a shell builtin\n" command) - 0) - (else (let ((program (PATH-search-path command))) - (if (string? program) (begin (format #t "~a hashed (~a)\n" command ) 0) - 1)))))) - ((option-ref options 'show #f) - (let* ((command (car files)) - (builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?))) - (if builtin (begin (stdout command) 0) - (let ((program (PATH-search-path command))) - (if (string? program) (begin (stdout program) 0) - 1))))) - (else (let* ((command (car files)) - (builtin (builtin command #:prefer-builtin? %prefer-builtins?))) - ;; FIXME: - `(command ,@args)))))))) + (version? (format #t "command (GASH) ~a\n" %version)) + ((null? files) #t) + ((option-ref options 'describe #f) + (let* ((command (car files)) + (builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?))) + (cond (builtin (format #t "~a is a shell builtin\n" command) + 0) + (else (let ((program (PATH-search-path command))) + (if (string? program) (begin (format #t "~a hashed (~a)\n" command ) 0) + 1)))))) + ((option-ref options 'show #f) + (let* ((command (car files)) + (builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?))) + (if builtin (begin (stdout command) 0) + (let ((program (PATH-search-path command))) + (if (string? program) (begin (stdout program) 0) + 1))))) + (else (let* ((command (car files)) + (builtin (builtin command #:prefer-builtin? %prefer-builtins?))) + ;; FIXME: + `(command ,@args))))))))) (define type-command (case-lambda (() #t) (args - (let* ((option-spec - '((help) - (canonical-file-name (single-char #\p)) - (version))) - (options (getopt-long (cons "type" args) option-spec)) - (help? (option-ref options 'help #f)) - (version? (option-ref options 'version #f)) - (files (option-ref options '() '()))) - (cond (help? (display "Usage: type [OPTION]... [COMMAND] + (lambda _ + (let* ((option-spec + '((help) + (canonical-file-name (single-char #\p)) + (version))) + (options (getopt-long (cons "type" args) option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (cond (help? (display "Usage: type [OPTION]... [COMMAND] Options: --help display this help and exit -p display canonical file name of COMMAND --version display version information and exit ")) - (version? (format #t "type (GASH) ~a\n" %version)) - ((null? files) #t) - ((option-ref options 'canonical-file-name #f) - (let* ((command (car files)) - (builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?))) - (if builtin 0 - (let ((program (PATH-search-path command))) - (and (string? program) - (stdout program) - 0))))) - (else - (let* ((command (car files)) - (builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?))) - (cond (builtin (format #t "~a is a shell builtin\n" command) - 0) - (else (let ((program (PATH-search-path command))) - (if (string? program) (begin (format #t "~a hashed (~a)\n" command ) 0) - 1))))))))))) + (version? (format #t "type (GASH) ~a\n" %version)) + ((null? files) #t) + ((option-ref options 'canonical-file-name #f) + (let* ((command (car files)) + (builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?))) + (if builtin 0 + (let ((program (PATH-search-path command))) + (and (string? program) + (stdout program) + 0))))) + (else + (let* ((command (car files)) + (builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?))) + (cond (builtin (format #t "~a is a shell builtin\n" command) + 0) + (else (let ((program (PATH-search-path command))) + (if (string? program) (begin (format #t "~a hashed (~a)\n" command ) 0) + 1)))))))))))) (define test-command (case-lambda (() #f) (args - (let* ((option-spec - '((is-directory (single-char #\d)) - (exists (single-char #\e)) - (has-size (single-char #\s)) - (help) - (is-directory (single-char #\d)) - (is-file (single-char #\f)) - (is-symbolic-link (single-char #\L)) - (is-symbolic-link (single-char #\h)) - (is-readable (single-char #\r)) - (is-writable (single-char #\w)) - (is-exeutable (single-char #\x)) - (string-not-null (single-char #\n)) - (string-null (single-char #\z)) - (version))) - (options (getopt-long (cons "test" args) option-spec)) - (help? (option-ref options 'help #f)) - (version? (option-ref options 'version #f)) - (files (option-ref options '() '())) - (file (and (pair? files) (car files))) - (no-options? (and file - (= (length options) 1)))) - (cond (help? (display "Usage: test [EXPRESSION] + (lambda _ + (let* ((option-spec + '((is-directory (single-char #\d)) + (exists (single-char #\e)) + (has-size (single-char #\s)) + (help) + (is-directory (single-char #\d)) + (is-file (single-char #\f)) + (is-symbolic-link (single-char #\L)) + (is-symbolic-link (single-char #\h)) + (is-readable (single-char #\r)) + (is-writable (single-char #\w)) + (is-exeutable (single-char #\x)) + (string-not-null (single-char #\n)) + (string-null (single-char #\z)) + (version))) + (options (getopt-long (cons "test" args) option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '())) + (file (and (pair? files) (car files))) + (no-options? (and file + (= (length options) 1)))) + (cond (help? (display "Usage: test [EXPRESSION] Expression: @@ -297,310 +275,87 @@ Options: --help display this help and exit --version display version information and exit ")) - (version? (format #t "test (GASH) ~a\n" %version)) - ((null? files) #f) - ((or (option-ref options 'n #f) - no-options?) - (not (string-null? file))) - ((option-ref options 'z #f) - (string-null? file)) - ((and (= (length files) 3) - (member (cadr files) '("=" "=="))) - (match files - ((or (left "=" right) - (left "==" right)) - (equal? left right)) - ((left "!=" right) - (not (equal? left right))) - (expression - (pipeline (command expression))))) - ((not (= (length files) 1)) - (format (current-error-port) "test: too many files: ~a\n" files) - 1) - ((option-ref options 'is-file #f) - (regular-file? file)) - ((option-ref options 'is-directory #f) - (directory-exists? file)) - ((option-ref options 'exists #f) - (file-exists? file)) - ((option-ref options 'is-symbolic-link #f) - (symbolic-link? file)) - ((option-ref options 'is-readable #f) - (access? file R_OK)) - ((option-ref options 'has-size #f) - (and (file-exists? file) - (not (zero? (stat:size (stat file)))))) - ((option-ref options 'is-writable #f) - (access? file W_OK)) - ((option-ref options 'is-exeutable #f) - (access? file X_OK)) - (else - (error "gash: test: not supported" args))))))) + (version? (format #t "test (GASH) ~a\n" %version)) + ((null? files) #f) + ((or (option-ref options 'n #f) + no-options?) + (not (string-null? file))) + ((option-ref options 'z #f) + (string-null? file)) + ((and (= (length files) 3) + (member (cadr files) '("=" "=="))) + (match files + ((or (left "=" right) + (left "==" right)) + (equal? left right)) + ((left "!=" right) + (not (equal? left right))) + (expression + (pipeline (command expression))))) + ((not (= (length files) 1)) + (format (current-error-port) "test: too many files: ~a\n" files) + 1) + ((option-ref options 'is-file #f) + (regular-file? file)) + ((option-ref options 'is-directory #f) + (directory-exists? file)) + ((option-ref options 'exists #f) + (file-exists? file)) + ((option-ref options 'is-symbolic-link #f) + (symbolic-link? file)) + ((option-ref options 'is-readable #f) + (access? file R_OK)) + ((option-ref options 'has-size #f) + (and (file-exists? file) + (not (zero? (stat:size (stat file)))))) + ((option-ref options 'is-writable #f) + (access? file W_OK)) + ((option-ref options 'is-exeutable #f) + (access? file X_OK)) + (else + (error "gash: test: not supported" args)))))))) (define bracket-command (case-lambda (() #f) (args - (cond ((and (pair? args) (equal? (car args) "--help")) - (test-command "--help")) - ((and (pair? args) (equal? (car args) "--version")) - (test-command "--version")) - (else - (if (not (equal? (last args) "]")) (begin - (format (current-error-port) "gash: [: missing `]'\n") - #f) - (apply test-command (drop-right args 1)))))))) - -(define grep-command - (case-lambda - (() #f) - (args - (let* ((option-spec - '((help) - (line-number (single-char #\n)) - (files-with-matches (single-char #\l)) - (files-without-match (single-char #\L)) - (with-file-name (single-char #\H)) - (no-file-name (single-char #\h)) - (only-matching (single-char #\o)) - (version (single-char #\V)))) - (options (getopt-long (cons "ls" args) option-spec)) - (help? (option-ref options 'help #f)) - (version? (option-ref options 'version #f)) - (files (option-ref options '() '()))) - (cond (help? (display "Usage: grep [OPTION]... PATTERN [FILE]... - -Options: - --help display this help and exit - -h, --no-filename suppress the file name prefix on output - -H, --with-filename print file name with output lines - -l, --files-with-matches print only names of FILEs with selected lines - -L, --files-without-match print only names of FILEs with no selected lines - -n, --line-number print line number with output lines - -o, --only-matching show only the part of a line matching PATTERN - -V, --version display version information and exit -")) - (version? (format #t "grep (GASH) ~a\n" %version)) - ((null? files) #t) + (lambda _ + (cond ((and (pair? args) (equal? (car args) "--help")) + (test-command "--help")) + ((and (pair? args) (equal? (car args) "--version")) + (test-command "--version")) (else - (let* ((pattern (car files)) - (files (cdr files)) - (matches (append-map (cut grep pattern <>) files))) - (define (display-match o) - (let* ((s (grep-match-string o)) - (s (if (option-ref options 'only-matching #f) - (substring s (grep-match-column o) (grep-match-end-column o)) - s)) - (s (if (option-ref options 'line-number #f) - (string-append (number->string (grep-match-line o)) ":" s) - s)) - (s (if (option-ref options 'with-file-name #f) - (string-append (grep-match-file-name o) ":" s) - s))) - (stdout s))) - (define (files-with-matches) - (delete-duplicates (map grep-match-file-name matches))) - (cond ((option-ref options 'files-with-matches #f) - (let ((result (files-with-matches))) - (and (pair? result) - (for-each stdout result) - 0))) - ((option-ref options 'files-without-match #f) - (let* ((result (files-with-matches)) - (result (filter (negate (cut member <> result)) files))) - (and (pair? result) - (for-each stdout result) - 0))) - (else - (and (pair? matches) - (for-each display-match matches) - 0)))))))))) + (if (not (equal? (last args) "]")) (begin + (format (current-error-port) "gash: [: missing `]'\n") + #f) + (apply test-command (drop-right args 1))))))))) -(define (PATH-search-path program) - (search-path (string-split (getenv "PATH") #\:) program)) - -(define* (builtin ast #:key prefer-builtin?) - ;; FIXME: distinguish between POSIX compliant builtins and - ;; `best-effort'/`fallback'? - "Possibly modify command to use a builtin." - (when (> %debug-level 0) - (format (current-error-port) "builtin ast=~s\n" ast)) - (receive (command args) - (match ast - (((and (? string?) command) args ...) (values command args)) - (_ (values #f #f))) - (let ((program (and command - (cond ((string-prefix? "/" command) - (when (not (file-exists? command)) - (format (current-error-port) "gash: ~a: no such file or directory\n" command)) - command) - (else (PATH-search-path command)))))) - ;; FIXME: find some generic strerror/errno way: what about permissions and stuff? - ;; after calling system* we're too late for that? - (when (> %debug-level 0) - (format (current-error-port) "command ~a => ~s ~s\n" (or program 'builtin) command args)) - (cond ((and program (not prefer-builtin?)) - (when (not program) - (format (current-error-port) "gash: ~a: command not found\n" command)) - (when (not (access? program X_OK)) - (format (current-error-port) "gash: ~a: permission denied\n" command)) - #f) - ((and command (assoc-ref %builtin-commands command)) - => - (lambda (command) - (if args - (apply command (map (cut local-eval <> (the-environment)) args)) - (command)))) - (else #f))))) - -(define (command . args) - (define (exec command) - (cond ((procedure? command) command) - ((every string? command) - (let* ((program (car command)) - (escape-builtin? (and (string? program) (string-prefix? "\\" program))) - (program (if escape-builtin? (string-drop program 1) program)) - (command (cons program (cdr command)))) - (or (builtin command #:prefer-builtin? (and %prefer-builtins? - (not escape-builtin?))) - (cut apply (compose status:exit-val system*) command)))) - (else (lambda () #t)))) - (exec (append-map glob args))) - -(define (glob pattern) - (define (glob? pattern) - (and (string? pattern) (string-match "\\?|\\*" pattern))) - (define (glob2regex pattern) - (let* ((pattern (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post)) - (pattern (regexp-substitute/global #f "\\?" pattern 'pre "." 'post)) - (pattern (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post))) - (make-regexp (string-append "^" pattern "$")))) - (define (glob-match regex path) ;; pattern path -> bool - (regexp-match? (regexp-exec regex path))) - (define (glob- pattern file-names) - (map (lambda (file-name) - (if (string-prefix? "./" file-name) (string-drop file-name 2) file-name)) - (append-map (lambda (file-name) - (map (cut string-append (if (string=? "/" file-name) "" file-name) "/" <>) - (filter (conjoin (negate (cut string-prefix? "." <>)) - (cute glob-match (glob2regex pattern) <>)) - (or (scandir file-name) '())))) - file-names))) - (cond - ((not pattern) '("")) - ((glob? pattern) (let ((absolute? (string-prefix? "/" pattern))) - (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) - (file-names (if absolute? '("/") '(".")))) - (if (null? patterns) - file-names - (begin - (loop (cdr patterns) (glob- (car patterns) file-names))))))) - (#t (list pattern)))) - -(define (singlequotes . o) - (string-join o "")) - -(define (doublequotes . o) - (string-join (append-map glob o) "")) - -(define (sequence . args) - (pke 'sequence (append-map glob (apply append args))) - ;;(pke 'sequence (map glob (pke 'apply-append (apply append (pke 'seq-args: args))))) - ;;(list (apply append args)) - ) - -(define (script . o) - o) - -(define (for name sequence body) - (for-each (lambda (value) - (assignment name value) - (body)) - (sequence))) - -(define (split o) - ((compose string-tokenize string-trim-right) o)) - -(define (xtrace o) - (o)) - -(define (word . o) - (apply string-append o)) - -(define-syntax-rule (substitution commands) - (let ((lst (pke 'split (split (pke 'string (with-output-to-string (lambda _ commands))))))) - (if (= (length lst) 1) (car lst) - lst))) - -(define-syntax if-clause - (lambda (x) - (syntax-case x () - ((_ expr then) - (with-syntax ((it (datum->syntax x 'it))) - #'(let ((it expr)) - (if (zero? it) then)))) - ((_ expr then else) - (with-syntax ((it (datum->syntax x 'it))) - #'(let ((it expr)) - (if (zero? it) then else))))))) - -(define (pipeline . commands) - (define (handle job) - (let* ((stati (cond ((job? job) (map status:exit-val (job-status job))) - ((boolean? job) (list (if job 0 1))) - ((number? job) (list job)) - (else (list 0)))) - (status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0) - (car stati))) - (pipestatus (string-append - "(" - (string-join - (map (lambda (s i) - (format #f "[~a]=\"~a\"" s i)) - stati - (iota (length stati)))) - ")"))) - (assignment "PIPESTATUS" pipestatus) - (assignment "?" (number->string status)) - (when (and (not (zero? status)) - (shell-opt? "errexit")) - (exit status)) - status)) - (when (> %debug-level 1) - (format (current-error-port) "pijp: commands=~s\n" commands)) - ;; FIXME: after running a builtin, we still end up here with the builtin's result - ;; that should probably not happen, however, cater for it here for now - (match commands - (((and (? boolean?) boolean)) - (handle boolean)) - (((and (? number?) number)) - (handle number)) - (((? unspecified?)) - (handle #t)) - (_ (handle (apply pipeline+ #t commands))))) +(define (trace commands) + `(xtrace + ,(lambda _ + (when (shell-opt? "xtrace") + (for-each + (lambda (o) + (match o + (('command (and command (? string?)) ...) + (format (current-error-port) "+ ~a\n" (string-join command))) + (_ format (current-error-port) "+ ~s \n" o))) + (reverse commands)))))) (define %builtin-commands `( ("bg" . ,bg-command) - ("cat" . ,cat-command) ("command" . ,command-command) ("cd" . ,cd-command) - ("cp" . ,cp-command) ("echo" . ,echo-command) + ("eval" . ,eval-command) ("exit" . ,exit-command) ("fg" . ,fg-command) - ("find" . ,find-command) - ("grep" . ,grep-command) ("help" . ,help-command) ("jobs" . ,jobs-command) - ("ls" . ,ls-command) ("pwd" . ,pwd-command) - ("reboot" . ,reboot-command) - ("rm" . ,rm-command) ("set" . ,set-command) ("test" . ,test-command) ("type" . ,type-command) - ("wc" . ,wc-command) - ("which" . ,which-command) ("[" . ,bracket-command) )) diff --git a/gash/environment.scm b/gash/environment.scm index 5dbcee1..81de2ba 100644 --- a/gash/environment.scm +++ b/gash/environment.scm @@ -27,6 +27,7 @@ %global-variables assignment set-shell-opt! + shell-opt? variable )) @@ -60,3 +61,6 @@ (filter (negate (cut equal? <> name)) options))) (new-shell-opts (string-join new-options ":"))) (assignment "SHELLOPTS" new-shell-opts))) + +(define (shell-opt? name) + (member name (string-split (assoc-ref %global-variables "SHELLOPTS") #\:))) diff --git a/gash/gash.scm b/gash/gash.scm index 585d2dc..e7fb092 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -18,57 +18,47 @@ #:use-module (gash environment) #:use-module (gash job) #:use-module (gash pipe) - #:use-module (gash peg) #:use-module (gash io) + #:use-module (gash script) #:use-module (gash util) #:export (main %debug-level %prefer-builtins? - shell-opt?)) + parse + parse-string)) (define %debug-level 0) ; 1 informational, 2 verbose, 3 peg tracing (define %prefer-builtins? #f) ; use builtin, even if COMMAND is available in PATH? +(define %geesh-parser? #f) ; use Geesh parser [EXPERIMENTAL] -(define (remove-shell-comments s) - (string-join (map - (lambda (s) - (let* ((n (string-index s #\#))) - (if n (string-pad-right s (string-length s) #\space 0 n) - s))) - (string-split s #\newline)) "\n")) +(define (parse-string string) + (let ((parser (cond (%geesh-parser? (@ (gash geesh) parse-string)) + (else (@ (gash peg) parse-string))))) + (parser string))) -(define (remove-escaped-newlines s) - (reduce (lambda (next prev) - (let* ((escaped? (string-suffix? "\\" next)) - (next (if escaped? (string-drop-right next 1) next)) - (sep (if escaped? "" "\n"))) - (string-append prev sep next))) - "" (string-split s #\newline))) - -(define (file-to-string file-name) - (format (current-error-port) "gash: reading: ~s\n" file-name) - (with-input-from-file file-name read-string)) - -(define (string-to-ast string) - ((compose parse remove-escaped-newlines remove-shell-comments) string)) +(define (parse port) + (let ((parser (cond (%geesh-parser? (@ (gash geesh) parse)) + (else (@ (gash peg) parse))))) + (parser port))) (define (file-to-ast file-name) - ((compose string-to-ast file-to-string) file-name)) + (call-with-input-file file-name parse)) (define (display-help) (display "\ Usage: gash [OPTION]... [FILE]... Options: - -c, --command=STRING Evaluate STRING and exit - -e, --errexit Exit upon error - -d, --debug Enable PEG tracing - -h, --help Display this help - -p, --parse Parse the shell script and print the parse tree - --prefer-builtins Use builtins, even if command is available in PATH - -v, --version Display the version - -x, --xtrace Print simple command trace + -c, --command=STRING Evaluate STRING and exit + -e, --errexit Exit upon error + -d, --debug Enable PEG tracing + -g, --geesh Use Geesh parser [EXPERIMENTAL] + -h, --help Display this help + -p, --parse Parse the shell script and print the parse tree + --prefer-builtins Use builtins, even if command is available in PATH + -v, --version Display the version + -x, --xtrace Print simple command trace ")) (define (display-version) @@ -93,6 +83,7 @@ copyleft. (help (single-char #\h)) (parse (single-char #\p)) (prefer-builtins) + (geesh (single-char #\g)) (version (single-char #\v)) (xtrace (single-char #\x)))) (options (getopt-long args option-spec #:stop-at-first-non-option #t )) @@ -105,6 +96,7 @@ copyleft. (version? (option-ref options 'version #f)) (files (option-ref options '() '()))) (set! %prefer-builtins? (option-ref options 'prefer-builtins #f)) + (set! %geesh-parser? (option-ref options 'geesh #f)) (set-shell-opt! "errexit" (option-ref options 'errexit #f)) (set-shell-opt! "xtrace" (option-ref options 'xtrace #f)) (when (option-ref options 'debug #f) @@ -112,19 +104,24 @@ copyleft. (cond (help? (display-help)) (version? (display-version)) - (command? (let ((ast (string-to-ast command?))) - (exit (assoc-ref %global-variables "?")))) + (command? (let ((ast (parse-string command?))) + (if parse? (pretty-print ast) + (run ast)) + (exit (script-status)))) ((pair? files) - (let* ((asts (map file-to-ast files)) - (status (assoc-ref %global-variables "?"))) - (exit status))) + (let ((asts (map file-to-ast files))) + (if parse? (map pretty-print asts) + (for-each run asts)) + (exit (script-status)))) (#t (let* ((HOME (string-append (getenv "HOME") "/.gash_history")) (thunk (lambda () (let loop ((line (readline (prompt)))) (when (not (eof-object? line)) - (let* ((ast (string-to-ast line))) + (let* ((ast (parse-string line))) (when (and ast (not (string-null? line))) + (unless parse? + (run ast)) (add-history line)) (loop (let ((previous (if ast "" (string-append line "\n"))) (next (readline (if ast (prompt) "> ")))) @@ -137,77 +134,6 @@ copyleft. (newline)))))))) (thunk))) -(define (expand identifier o) ;;identifier-string -> symbol - (define (expand- o) - (let ((dollar-identifier (string-append "$" identifier))) - (match o - ((? symbol?) o) - ((? string?) (if (string=? o dollar-identifier) (string->symbol identifier) o)) - ((? list?) (map expand- o)) - (_ o)))) - (map expand- o)) - -(define (DEAD-background ast) - (match ast - (('pipeline fg rest ...) `(pipeline #f ,@rest)) - (_ ast))) - -(define (shell-opt? name) - (member name (string-split (assoc-ref %global-variables "SHELLOPTS") #\:))) - -(define (tostring . args) - (with-output-to-string (cut map display args))) - -;; transform ast -> list of expr -;; such that (map eval expr) -(define (DEAD-transform ast) - (format (current-error-port) "transform=~s\n" ast) - (match ast - (('script term "&") (list (background (transform term)))) - (('script term) `(,(transform term))) - (('script terms ...) (transform terms)) - (('substitution "$(" script ")") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment))) - (('substitution "`" script "`") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment))) - ((('term command)) `(,(transform command))) - ((('term command) ...) (map transform command)) - ((('term command) (('term commands) ...)) (map transform (cons command commands))) - (('compound-list terms ...) (transform terms)) - (('if-clause "if" (expression "then" consequent "fi")) - `(if (equal? 0 (status:exit-val ,@(transform expression))) - (begin ,@(transform consequent)))) - (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) - `(if (equal? 0 (status:exit-val ,@(transform expression))) - (begin ,@(transform consequent)) - (begin ,@(transform alternative)))) - (('for-clause ("for" identifier sep do-group)) #t) - (('for-clause "for" ((identifier "in" lst sep) do-group)) - `(for-each (lambda (,(string->symbol identifier)) - (begin ,@(expand identifier (transform do-group)))) - (glob ,(transform lst)))) - (('do-group "do" (command "done")) (transform command)) - (('pipeline command) (pk 1) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,@command)))) - (('pipeline command piped-commands) (pk 2) `(pipeline #t ,@(transform command) ,@(transform piped-commands))) - (('simple-command ('word (assignment name value))) `((lambda _ (let ((name ,(tostring (transform name))) - (value ,(tostring (transform value)))) - (stderr "assignment: " name "=" value) - (set! global-variables (assoc-set! global-variables name (glob value))))))) - (('simple-command ('word s)) `((glob ,(transform s)))) - (('simple-command ('word s1) ('io-redirect "<<" ('here-document s2))) `((append (glob "echo") (cons "-n" (glob ,s2))) (glob ,(transform s1)))) - (('simple-command ('word s1) ('word s2)) `((append (glob ,(transform s1)) (glob ,(transform s2))))) - (('simple-command ('word s1) (('word s2) ...)) `((append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2)))))) - (('variable s) s) - (('literal s) (transform s)) - (('singlequotes s) (string-concatenate `("'" ,s "'"))) - (('doublequotes s) (string-concatenate `("\"" ,s "\""))) - (('backticks s) (string-concatenate `("`" ,s "`"))) - (('delim ('singlequotes s ...)) (string-concatenate (map transform s))) - (('delim ('doublequotes s ...)) (string-concatenate (map transform s))) - (('delim ('backticks s ...)) (string-concatenate (map transform s))) - ((('pipe _) command) (transform command)) - (((('pipe _) command) ...) (map (compose car transform) command)) - ((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...) - (_ ast))) ;; done - (define prompt (let* ((l (string #\001)) (r (string #\002)) diff --git a/gash/geesh.scm b/gash/geesh.scm new file mode 100644 index 0000000..db7546a --- /dev/null +++ b/gash/geesh.scm @@ -0,0 +1,127 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +(define-module (gash geesh) + #:use-module (srfi srfi-1) + + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + + #:use-module (gash builtins) + #:use-module (gash gash) + #:use-module (gash io) + #:use-module (geesh parser) + #:export ( + parse + parse-string + )) + +(define (parse port) + (let ((parse-tree (read-sh-all port))) + (when (> %debug-level 1) + (format (current-error-port) "parse-tree:\n") + (pretty-print parse-tree (current-error-port))) + (let ((ast (parse-tree->script parse-tree))) + (format (current-error-port) "transformed:\n") + (pretty-print ast (current-error-port)) + (let* ((script (match ast + (((or 'command 'pipeline) _ ...) `(script ,ast)) + ((_ ...) `(script ,@ast)) + (_ `(script ,ast)))) + (tracing-script (annotate-tracing script))) + (when (> %debug-level 0) + (format (current-error-port) "script:\n") + (pretty-print tracing-script (current-error-port))) + tracing-script)))) + +(define (parse-string string) + (call-with-input-string string parse)) + +(define (parse-tree->script tree) + (define (transform o) + (when (> %debug-level 2) + (format (current-error-port) "transform:\n") + (pretty-print o (current-error-port))) + (match o + ((' body ...) `(begin ,@(map transform body))) + ((' ((' (left ...))) right) + `(pipeline ,@(map transform left) ,(transform right))) + ((' (' (left ...) right)) + `(pipeline ,@(map transform left) ,(transform right))) + ((' (left right)) + `(pipeline ,(transform left) ,(transform right))) + ((' command) `(command ,(transform command))) + ((' command ...) `(command ,@(map transform command))) + (((and ref (' _)) words ...) + `(word ,(transform ref) ,@(map transform words))) + ((' var) `(variable ,var)) + ((' (var (and value ((? symbol?) _ ...)))) + `(assignment ,(transform var) ,(transform value))) + ((' (var (value ...))) + `(assignment ,(transform var) (word ,@(map transform value)))) + ((' (var value)) `(assignment ,(transform var) ,(transform value))) + (((and kwote (' _)) word) + `(word ,(transform kwote) ,(transform word))) + ((') + `(doublequotes "")) + ((' words ...) + `(doublequotes (word ,@(map transform words)))) + (((and quote (' _)) tail ...) + `(word ,(transform quote) ,@(map transform tail))) + ((' cmd) `(substitution ,(transform cmd))) + ((' (expression then)) `(if-clause ,(transform expression) ,(transform then))) + ((' (('<< 0 string)) pipeline) + (let ((pipeline (pke 'pipeline (transform pipeline)))) + `(pipeline (display ,(transform string)) + ,@(match pipeline + (('command command ...) `(,pipeline)) + (('pipeline commands ...) commands))))) + + ((' (name (sequence)) body) + `(for ,(transform name) + (lambda _ (split ,(transform sequence))) + (lambda _ ,(transform body)))) + + ((' (name sequence) body) + `(for ,(transform name) + (lambda _ (split ,(transform sequence))) + (lambda _ ,(transform body)))) + + ((? string?) o) + (((? string?) _ ...) `(word ,@(map re-word o))) + ((_ ...) (map transform o)) + (_ o))) + (transform tree)) + +(define (re-word word) + (match word + ((? string?) word) + (((and h (? string?)) t ...) + `(word ,h ,@(map (compose re-word parse-tree->script) t))) + (_ (parse-tree->script word)))) + +(define (annotate-tracing script) + (match script + (('pipeline command) + `(pipeline ,(trace (list command)) ,command)) + (('pipeline commands ...) + `(pipeline ,(trace commands) ,@commands)) + (('command command ...) + `(pipeline ,(trace (list script)) ,script)) + ((_ ...) (map annotate-tracing script)) + (_ script))) diff --git a/gash/guix-build-utils.scm b/gash/guix-build-utils.scm index a9c2639..5e60386 100644 --- a/gash/guix-build-utils.scm +++ b/gash/guix-build-utils.scm @@ -34,6 +34,7 @@ dump-port file-name-predicate find-files + grep* grep grep-match-file-name @@ -163,17 +164,24 @@ transferred and the continuation of the transfer as a thunk." (column grep-match-column) (end-column grep-match-end-column)) -(define (grep regexp file) - (call-with-input-file file - (lambda (in) - (let loop ((line (read-line in)) (ln 1) (matches '())) - (if (eof-object? line) (reverse matches) - (let* ((m (list-matches regexp line)) - (m (and (pair? m) (car m)))) - (loop (read-line in) (1+ ln) - (if m (cons (make-grep-match file - (match:string m) - ln - (match:start m) - (match:end m)) matches) - matches)))))))) +(define* (grep* pattern #:key (port (current-input-port)) (file-name "")) + ;; FIXME: collect later? for scripting usage implicit collect is + ;; nice; for pipeline usage not so much + (let loop ((line (read-line port)) (ln 1) (matches '())) + (if (eof-object? line) (reverse matches) + (let* ((m (list-matches pattern line)) + (m (and (pair? m) (car m)))) + (loop (read-line port) (1+ ln) + (if m (cons (make-grep-match file-name + (match:string m) + ln + (match:start m) + (match:end m)) matches) + matches)))))) + +(define (grep pattern file) + (cond ((and (string? file) + (not (equal? file "-"))) (call-with-input-file file + (lambda (in) + (grep* pattern #:port in #:file-name file)))) + (else (grep* pattern)))) diff --git a/gash/job.scm b/gash/job.scm index 5220244..fe0b906 100644 --- a/gash/job.scm +++ b/gash/job.scm @@ -7,18 +7,21 @@ #:use-module (gash io) #:use-module (gash util) - #:export (bg + #:export ( + bg fg + display-job + job-table job? job-add-process job-control-init job-debug-id job-setup-process job-status - jobs-command new-job report-jobs - wait)) + wait + )) (define-record-type (make-process pid command status) @@ -67,9 +70,6 @@ (stdout "[" (job-id job) "] " (map status->state (job-status job)) "\t\t" (job-command job))) -(define (jobs-command) - (for-each (lambda (job) (display-job job)) (reverse job-table))) - (define (job-status job) (map process-status (job-processes job))) diff --git a/gash/peg.scm b/gash/peg.scm index af9228a..b012077 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -4,6 +4,7 @@ #:use-module (ice-9 pretty-print) #:use-module (ice-9 peg) #:use-module (ice-9 peg codegen) + #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) @@ -13,10 +14,11 @@ #:use-module (gash environment) #:use-module (gash gash) #:use-module (gash io) - #:use-module (gash job) + #:use-module (gash script) #:export ( parse + parse-string peg-trace? )) @@ -64,6 +66,74 @@ (or (loop (car x)) (loop (cdr x))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;; WIP +(define (expand identifier o) ;;identifier-string -> symbol + (define (expand- o) + (let ((dollar-identifier (string-append "$" identifier))) + (match o + ((? symbol?) o) + ((? string?) (if (string=? o dollar-identifier) (string->symbol identifier) o)) + ((? list?) (map expand- o)) + (_ o)))) + (map expand- o)) + +(define (tostring . args) + (with-output-to-string (cut map display args))) + +;; transform ast -> list of expr +;; such that (map eval expr) +(define (DEAD-transform ast) + (format (current-error-port) "transform=~s\n" ast) + (match ast + (('script term "&") (list (background (transform term)))) + (('script term) `(,(transform term))) + (('script terms ...) (transform terms)) + (('substitution "$(" script ")") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment))) + (('substitution "`" script "`") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment))) + ((('term command)) `(,(transform command))) + ((('term command) ...) (map transform command)) + ((('term command) (('term commands) ...)) (map transform (cons command commands))) + (('compound-list terms ...) (transform terms)) + (('if-clause "if" (expression "then" consequent "fi")) + `(if (equal? 0 (status:exit-val ,@(transform expression))) + (begin ,@(transform consequent)))) + (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) + `(if (equal? 0 (status:exit-val ,@(transform expression))) + (begin ,@(transform consequent)) + (begin ,@(transform alternative)))) + (('for-clause ("for" identifier sep do-group)) #t) + (('for-clause "for" ((identifier "in" lst sep) do-group)) + `(for-each (lambda (,(string->symbol identifier)) + (begin ,@(expand identifier (transform do-group)))) + (glob ,(transform lst)))) + (('do-group "do" (command "done")) (transform command)) + (('pipeline command) (pk 1) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,@command)))) + (('pipeline command piped-commands) (pk 2) `(pipeline #t ,@(transform command) ,@(transform piped-commands))) + (('simple-command ('word (assignment name value))) `((lambda _ (let ((name ,(tostring (transform name))) + (value ,(tostring (transform value)))) + (stderr "assignment: " name "=" value) + (set! global-variables (assoc-set! global-variables name (glob value))))))) + (('simple-command ('word s)) `((glob ,(transform s)))) + (('simple-command ('word s1) ('io-redirect "<<" ('here-document s2))) `((append (glob "echo") (cons "-n" (glob ,s2))) (glob ,(transform s1)))) + (('simple-command ('word s1) ('word s2)) `((append (glob ,(transform s1)) (glob ,(transform s2))))) + (('simple-command ('word s1) (('word s2) ...)) `((append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2)))))) + (('variable s) s) + (('literal s) (transform s)) + (('singlequotes s) (string-concatenate `("'" ,s "'"))) + (('doublequotes s) (string-concatenate `("\"" ,s "\""))) + (('backticks s) (string-concatenate `("`" ,s "`"))) + (('delim ('singlequotes s ...)) (string-concatenate (map transform s))) + (('delim ('doublequotes s ...)) (string-concatenate (map transform s))) + (('delim ('backticks s ...)) (string-concatenate (map transform s))) + ((('pipe _) command) (transform command)) + (((('pipe _) command) ...) (map (compose car transform) command)) + ((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...) + (_ ast))) ;; done + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (parse- input) (define label "") (define (label-name str len pos) @@ -195,36 +265,10 @@ (define (flatten o) (keyword-flatten '(and assignent command doublequotes for-clause literal name or pipeline singlequotes substitution word) o)) -(define (parse input) - (let* ((pt (parse- input)) - (foo (when (> %debug-level 1) (display "tree:\n") (pretty-print pt))) - (flat (flatten pt)) - (foo (when (> %debug-level 0) (display "flat:\n") (pretty-print flat))) - (ast (transform flat)) - (foo (when (> %debug-level 0) (display "ast:\n") (pretty-print ast)))) - (cond ((error? ast) - (stderr "error:") (pretty-print ast (current-error-port)) #f) - ((eq? ast 'script) - #t) - (else - (map (cut local-eval <> (the-environment)) ast) - ast)))) (define (unspecified? o) (eq? o *unspecified*)) -(define (trace commands) - `(xtrace - ,(lambda _ - (when (shell-opt? "xtrace") - (for-each - (lambda (o) - (match o - (('command (and command (? string?)) ...) - (format (current-error-port) "+ ~a\n" (string-join command))) - (_ format (current-error-port) "+ ~s \n" o))) - (reverse commands)))))) - (define (transform ast) (when (> %debug-level 1) (pretty-print ast (current-error-port))) @@ -240,8 +284,10 @@ ((('singlequotes _ ...) _ ...) (map transform (flatten ast))) ((('word _ ...) _ ...) (map transform (flatten ast))) + (('script ('pipeline ('command command ... (word (literal "&"))))) + (background `(pipeline ',(map transform command)))) - (('script o ...) `(script ,@(map transform o))) + (('script terms ...) `(script ,@(map transform terms))) (('pipeline o ...) (let ((commands (map transform o))) @@ -254,6 +300,7 @@ ;;(('assignment a b) `(assignment ,(transform a) ',(transform b))) ;; FIXME: to quote or not? + (('assignment a) `(substitution (variable ,(transform a)))) (('assignment a b) `(assignment ,(transform a) ,(transform b))) ;; (('assignment a (and b ('literal _ ...))) `(assignment ,(transform a) ,(transform b))) @@ -261,8 +308,8 @@ ;; `(assignment ,(transform a) ,(map transform b))) - (('for-clause name expr (and body ('pipeline _ ...))) - `(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,(transform body)))) + (('for-clause name sequence (and body ('pipeline _ ...))) + `(for ,(transform name) (lambda _ ,(transform sequence)) (lambda _ ,(transform body)))) (('for-clause name expr body) `(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,@(map transform body)))) (('sequence o) @@ -290,3 +337,37 @@ (('word o) (transform o)) (('word o ...) `(string-append ,@(map transform o))) (_ ast))) + + +(define (remove-shell-comments s) + (string-join (map + (lambda (s) + (let* ((n (string-index s #\#))) + (if n (string-pad-right s (string-length s) #\space 0 n) + s))) + (string-split s #\newline)) "\n")) + +(define (remove-escaped-newlines s) + (reduce (lambda (next prev) + (let* ((escaped? (string-suffix? "\\" next)) + (next (if escaped? (string-drop-right next 1) next)) + (sep (if escaped? "" "\n"))) + (string-append prev sep next))) + "" (string-split s #\newline))) + +(define (parse-string string) + (let* ((pt ((compose parse- remove-escaped-newlines remove-shell-comments) string)) + (foo (when (> %debug-level 1) (display "tree:\n") (pretty-print pt))) + (flat (flatten pt)) + (foo (when (> %debug-level 0) (display "flat:\n") (pretty-print flat))) + (ast (transform flat)) + (foo (when (> %debug-level 0) (display "ast:\n") (pretty-print ast)))) + (cond ((error? ast) + (stderr "error:") (pretty-print ast (current-error-port)) #f) + ((eq? ast 'script) + #t) + (else ast)))) + +(define (parse port) + (parse-string (read-string port))) + diff --git a/gash/script.scm b/gash/script.scm new file mode 100644 index 0000000..f223846 --- /dev/null +++ b/gash/script.scm @@ -0,0 +1,251 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +(define-module (gash script) + #:use-module (ice-9 ftw) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 local-eval) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 receive) + #:use-module (ice-9 regex) + + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + + #:use-module (gash bournish-commands) + #:use-module (gash builtins) + #:use-module (gash config) + #:use-module (gash environment) + #:use-module (gash gash) + #:use-module (gash guix-build-utils) + #:use-module (gash io) + #:use-module (gash job) + #:use-module (gash pipe) + #:use-module (gash util) + + #:export ( + background + builtin + command + doublequotes + for + glob + if-clause + ignore-error + pipeline + run + script + script-status + sequence + singlequotes + splice + split + substitution + word + xtrace + )) + +(define (background term) + (format (current-error-port) "background: ~s\n" term) + (match (pke 'background-term term) + (('pipeline command) (pke 'background: `(pipeline+ #f ,command))) + (_ term))) + +(define (command . args) + (define (exec command) + (cond ((procedure? command) command) + ((every string? command) + (let* ((program (car command)) + (escape-builtin? (and (string? program) (string-prefix? "\\" program))) + (program (if escape-builtin? (string-drop program 1) program)) + (command (cons program (cdr command)))) + (or (builtin command #:prefer-builtin? (and %prefer-builtins? + (not escape-builtin?))) + (cut apply (compose status:exit-val system*) command)))) + (else (lambda () #t)))) + (exec (append-map glob args))) + +(define (glob pattern) + (define (glob? pattern) + (and (string? pattern) (string-match "\\?|\\*" pattern))) + (define (glob2regex pattern) + (let* ((pattern (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post)) + (pattern (regexp-substitute/global #f "\\?" pattern 'pre "." 'post)) + (pattern (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post))) + (make-regexp (string-append "^" pattern "$")))) + (define (glob-match regex path) ;; pattern path -> bool + (regexp-match? (regexp-exec regex path))) + (define (glob- pattern file-names) + (map (lambda (file-name) + (if (string-prefix? "./" file-name) (string-drop file-name 2) file-name)) + (append-map (lambda (file-name) + (map (cut string-append (if (string=? "/" file-name) "" file-name) "/" <>) + (filter (conjoin (negate (cut string-prefix? "." <>)) + (cute glob-match (glob2regex pattern) <>)) + (or (scandir file-name) '())))) + file-names))) + (cond + ((not pattern) '("")) + ((glob? pattern) (let ((absolute? (string-prefix? "/" pattern))) + (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) + (file-names (if absolute? '("/") '(".")))) + (if (null? patterns) + file-names + (begin + (loop (cdr patterns) (glob- (car patterns) file-names))))))) + (#t (list pattern)))) + +(define (singlequotes . o) + (string-join o "")) + +(define (doublequotes . o) + (string-join (append-map glob o) "")) + +(define (sequence . args) + (format (current-error-port) "sequence args=~s\n" args) + (let ((glob (append-map glob (apply append args)))) + (format (current-error-port) " => sequence glob=~s\n" glob) + glob)) + +(define (run ast) + (map (cut local-eval <> (the-environment)) ast)) + +(define (script-status) + ((compose string->number variable) "?")) + +(define (script . o) + o) + +(define (for name sequence body) + (for-each (lambda (value) + (assignment name value) + (body)) + (sequence))) + +(define (split o) + ((compose string-tokenize string-trim-right) o)) + +(define (xtrace o) + (o)) + +(define (word . o) + (define (flatten o) + (match o + ((h t ...) (append (flatten h) (append-map flatten t))) + (_ (list o)))) + (string-join (flatten o) "")) + +(define-syntax-rule (substitution commands) + (with-output-to-string (lambda _ commands))) + +(define-syntax-rule (ignore-error o) + (let ((errexit (shell-opt? "errexit"))) + (when errexit + (set-shell-opt! "errexit" #f)) + (let ((r o)) + (assignment "?" "0") + (when errexit + (set-shell-opt! " errexit" #t)) + r))) + +(define-syntax if-clause + (lambda (x) + (syntax-case x () + ((_ expr then) + (with-syntax ((it (datum->syntax x 'it))) + #'(let ((it (ignore-error expr))) + (if (zero? it) then)))) + ((_ expr then else) + (with-syntax ((it (datum->syntax x 'it))) + #'(let ((it (ignore-error expr))) + (if (zero? it) then else))))))) + +(define (pipeline . commands) + (define (handle job) + (when (> %debug-level 1) + (format (current-error-port) "job=~s\n" job)) + (let* ((stati (cond ((job? job) (map status:exit-val (job-status job))) + ((boolean? job) (list (if job 0 1))) + ((number? job) (list job)) + (else (list 0)))) + (foo (when (> %debug-level 1) + (format (current-error-port) "stati=~s\n" stati))) + (status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0) + (car stati))) + (pipestatus (string-append + "(" + (string-join + (map (lambda (s i) + (format #f "[~a]=\"~a\"" s i)) + stati + (iota (length stati)))) + ")"))) + (assignment "PIPESTATUS" pipestatus) + (assignment "?" (number->string status)) + (when (and (not (zero? status)) + (shell-opt? "errexit")) + (exit status)) + status)) + (when (> %debug-level 1) + (format (current-error-port) "pijp: commands=~s\n" commands)) + ;; FIXME: after running a builtin, we still end up here with the builtin's result + ;; that should probably not happen, however, cater for it here for now + (match commands + (((and (? boolean?) boolean)) + (handle boolean)) + (((and (? number?) number)) + (handle number)) + (((? unspecified?)) + (handle #t)) + (_ (handle (apply pipeline+ #t commands))))) + +(define* (builtin ast #:key prefer-builtin?) + ;; FIXME: distinguish between POSIX compliant builtins and + ;; `best-effort'/`fallback'? + "Possibly modify command to use a builtin." + (when (> %debug-level 0) + (format (current-error-port) "builtin ast=~s\n" ast)) + (receive (command args) + (match ast + (((and (? string?) command) args ...) (values command args)) + (_ (values #f #f))) + (let ((program (and command + (cond ((string-prefix? "/" command) + (when (not (file-exists? command)) + (format (current-error-port) "gash: ~a: no such file or directory\n" command)) + command) + (else (PATH-search-path command)))))) + ;; FIXME: find some generic strerror/errno way: what about permissions and stuff? + ;; after calling system* we're too late for that? + (when (> %debug-level 0) + (format (current-error-port) "command ~a => ~s ~s\n" (or program 'builtin) command args)) + (cond ((and program (not prefer-builtin?)) + (when (not program) + (format (current-error-port) "gash: ~a: command not found\n" command)) + (when (not (access? program X_OK)) + (format (current-error-port) "gash: ~a: permission denied\n" command)) + #f) + ((and command (or (assoc-ref %builtin-commands command) + (assoc-ref %bournish-commands command))) + => + (lambda (command) + (if args + (apply command (map (cut local-eval <> (the-environment)) args)) + (command)))) + (else #f))))) diff --git a/gash/util.scm b/gash/util.scm index ce1c8b5..6bd68ad 100644 --- a/gash/util.scm +++ b/gash/util.scm @@ -2,7 +2,11 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) - #:export (disjoin conjoin)) + #:export ( + conjoin + disjoin + wrap-command + )) (define (disjoin . predicates) (lambda (. arguments) @@ -11,3 +15,11 @@ (define (conjoin . predicates) (lambda (. arguments) (every (cut apply <> arguments) predicates))) + +(define (wrap-command command name) + (lambda args + (catch #t + (cut apply command args) + (lambda (key . args) + (format (current-error-port) "~a: ~a ~a\n" name key args) + 1)))) diff --git a/test.sh b/test.sh index 92f269c..77c258d 100755 --- a/test.sh +++ b/test.sh @@ -1,11 +1,12 @@ if [ -n "$BUILD_DEBUG" ]; then set -x fi -SHELL=${SHELL-bin/gash} +#SHELL=${SHELL-bin/gash} +SHELL=bin/gash for f in test/*.sh; do echo -n "$f: " b=test/$(basename $f .sh) - $SHELL -e $f + $SHELL --geesh -e $f r=$? if [ -f $b.exit ]; then e=$(cat $b.exit) diff --git a/test/05-assignment-doublequoted-doublequotes.sh b/test/05-assignment-doublequoted-doublequotes.sh new file mode 100644 index 0000000..ef6751f --- /dev/null +++ b/test/05-assignment-doublequoted-doublequotes.sh @@ -0,0 +1,5 @@ +#set -x +aliaspath=alias +localedir=x +defines="-DALIASPATH=\"${aliaspath}\" -DLOCALEDIR=\"${localedir}\"" +echo cc $defines diff --git a/test/06-assignment-singlequote.sh b/test/06-assignment-singlequote.sh new file mode 100644 index 0000000..77f0bb1 --- /dev/null +++ b/test/06-assignment-singlequote.sh @@ -0,0 +1 @@ +srcdir='.' diff --git a/test/07-assignment-double-quote.sh b/test/07-assignment-double-quote.sh new file mode 100644 index 0000000..6b03911 --- /dev/null +++ b/test/07-assignment-double-quote.sh @@ -0,0 +1 @@ +srcdir="." diff --git a/test/08-assignment-variable-word.sh b/test/08-assignment-variable-word.sh new file mode 100644 index 0000000..4525fdf --- /dev/null +++ b/test/08-assignment-variable-word.sh @@ -0,0 +1 @@ +libdir=${exec_prefix}/lib diff --git a/test/09-compound-word.sh b/test/09-compound-word.sh new file mode 100644 index 0000000..e806293 --- /dev/null +++ b/test/09-compound-word.sh @@ -0,0 +1,2 @@ +srcdir=. +echo cc -c ${srcdir}/$file diff --git a/test/0a-assign-substitute.sh b/test/0a-assign-substitute.sh new file mode 100644 index 0000000..91b1091 --- /dev/null +++ b/test/0a-assign-substitute.sh @@ -0,0 +1,2 @@ +obj=ar.o +objs="$objs `basename $obj`" diff --git a/test/0b-command-compound-word.sh b/test/0b-command-compound-word.sh new file mode 100644 index 0000000..224bcd8 --- /dev/null +++ b/test/0b-command-compound-word.sh @@ -0,0 +1,3 @@ +CC=echo +file=ar.o +$CC -I${srcdir} $file diff --git a/test/10-if.sh b/test/10-if.sh new file mode 100644 index 0000000..f61cd14 --- /dev/null +++ b/test/10-if.sh @@ -0,0 +1,4 @@ +if true; then + exit 0 +fi +exit 1 diff --git a/test/11-if-false.sh b/test/11-if-false.sh new file mode 100644 index 0000000..04581c1 --- /dev/null +++ b/test/11-if-false.sh @@ -0,0 +1,4 @@ +if false; then + exit 1 +fi +exit 0 diff --git a/test/08-assignment-susbtitution.sh b/test/30-assignment-substitution.sh similarity index 100% rename from test/08-assignment-susbtitution.sh rename to test/30-assignment-substitution.sh diff --git a/test/30-eval.sh b/test/30-eval.sh new file mode 100644 index 0000000..c5f9af1 --- /dev/null +++ b/test/30-eval.sh @@ -0,0 +1 @@ +eval echo 0 diff --git a/test/31-eval-echo-variable.sh b/test/31-eval-echo-variable.sh new file mode 100644 index 0000000..5882a93 --- /dev/null +++ b/test/31-eval-echo-variable.sh @@ -0,0 +1,2 @@ +bar=SHELL +eval echo '$'$bar diff --git a/test/32-for-substitute.sh b/test/32-for-substitute.sh new file mode 100644 index 0000000..a2a630e --- /dev/null +++ b/test/32-for-substitute.sh @@ -0,0 +1,3 @@ +for file in `echo ar.o arscan.o`; do + echo compiling ${file}... +done diff --git a/test/35-assignment-eval-echo.sh b/test/35-assignment-eval-echo.sh new file mode 100644 index 0000000..905da22 --- /dev/null +++ b/test/35-assignment-eval-echo.sh @@ -0,0 +1 @@ +exec_prefix=`eval echo ${prefix}` diff --git a/test/assign2.sh b/test/assign2.sh index 190d2de..5a9c238 100644 --- a/test/assign2.sh +++ b/test/assign2.sh @@ -1 +1,3 @@ defines="-DALIASPATH=\"${aliaspath}\" -" +echo defines:$defines + diff --git a/test/for-split-sequence.sh b/test/for-split-sequence.sh new file mode 100644 index 0000000..4716fe7 --- /dev/null +++ b/test/for-split-sequence.sh @@ -0,0 +1,5 @@ +one=1 +two_n_halve= +for i in 0 $one 2 $two_n_halve 3 ""; do + echo $i; +done diff --git a/test/for.sh b/test/for.sh new file mode 100644 index 0000000..a647d4e --- /dev/null +++ b/test/for.sh @@ -0,0 +1,3 @@ +for i in 0 1 2; do + echo $i; +done diff --git a/test/if.sh b/test/if.sh deleted file mode 100644 index b0e4dd0..0000000 --- a/test/if.sh +++ /dev/null @@ -1,3 +0,0 @@ -if [ x"$y" != x ]; then - echo boo -fi diff --git a/test/iohere.sh b/test/iohere.sh index 12cda66..15ff922 100644 --- a/test/iohere.sh +++ b/test/iohere.sh @@ -1,4 +1,3 @@ cat < Date: Sun, 21 Oct 2018 15:24:24 +0200 Subject: [PATCH 158/312] gash: resurrect. --- gash/peg.scm | 18 +++--------------- gash/script.scm | 4 ++++ test.sh | 3 ++- test/32-for-substitute.sh | 2 +- test/33-string-args.sh | 1 + 5 files changed, 11 insertions(+), 17 deletions(-) create mode 100644 test/33-string-args.sh diff --git a/gash/peg.scm b/gash/peg.scm index b012077..3f38b82 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -307,27 +307,15 @@ ;; (('assignment a b) ;; `(assignment ,(transform a) ,(map transform b))) - (('for-clause name sequence (and body ('pipeline _ ...))) `(for ,(transform name) (lambda _ ,(transform sequence)) (lambda _ ,(transform body)))) (('for-clause name expr body) `(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,@(map transform body)))) (('sequence o) - `(sequence ,@(fold-right (lambda (o r) - (cons - (match o - (('substitution x) (transform o)) - (_ `(list ,(transform o)))) - r)) - '() o))) + `(sequence (string-split ,(transform o) #\space))) (('sequence o ...) - `(sequence ,@(fold-right (lambda (o r) - (cons - (match o - (('substitution x) (transform o)) - (_ `(list ,(transform o)))) - r)) - '() o))) + `(sequence (quote ,(map transform o)))) + (('substitution o) `(substitution ,(transform o))) (('if-clause expr then) `(if-clause ,(transform expr) ,(transform then))) (('if-clause expr then else) `(if-clause ,(transform expr) ,(transform then) ,(transform else))) diff --git a/gash/script.scm b/gash/script.scm index f223846..0ac2d27 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -48,6 +48,7 @@ glob if-clause ignore-error + literal pipeline run script @@ -144,6 +145,9 @@ (define (xtrace o) (o)) +(define (literal o) + o) + (define (word . o) (define (flatten o) (match o diff --git a/test.sh b/test.sh index 77c258d..cda17f0 100755 --- a/test.sh +++ b/test.sh @@ -6,7 +6,8 @@ SHELL=bin/gash for f in test/*.sh; do echo -n "$f: " b=test/$(basename $f .sh) - $SHELL --geesh -e $f +# $SHELL --geesh -e $f + $SHELL -e $f r=$? if [ -f $b.exit ]; then e=$(cat $b.exit) diff --git a/test/32-for-substitute.sh b/test/32-for-substitute.sh index a2a630e..3a5b9ee 100644 --- a/test/32-for-substitute.sh +++ b/test/32-for-substitute.sh @@ -1,3 +1,3 @@ for file in `echo ar.o arscan.o`; do - echo compiling ${file}... + echo compiling $file... done diff --git a/test/33-string-args.sh b/test/33-string-args.sh new file mode 100644 index 0000000..0abb456 --- /dev/null +++ b/test/33-string-args.sh @@ -0,0 +1 @@ +echo foo "bar" '"baz"' \"bla\" From 019464acf660225bd8c44a418d0da439137aae24 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 21 Oct 2018 16:13:29 +0200 Subject: [PATCH 159/312] fix: set -e. --- gash/script.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/gash/script.scm b/gash/script.scm index 0ac2d27..129e907 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -217,6 +217,8 @@ (handle number)) (((? unspecified?)) (handle #t)) + (((? unspecified?) t ... #t) + #t) (_ (handle (apply pipeline+ #t commands))))) (define* (builtin ast #:key prefer-builtin?) From b8b170530cff9760b4cd986426b1e62354725cba Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 26 Oct 2018 14:55:00 +0200 Subject: [PATCH 160/312] bournish: Add tar, from Guile100 challenge by Mark Weaver. See https://github.com/spk121/guile100 * bin/tar.in: New file. * configure: Produce bin/tar. * .gitignore: Ignore it. * makefile (bin/tar): New target. * gash/tar.scm: New file. * gash/ustar.scm: New file. * build-aux/build-guile.sh: Compile new files. --- .gitignore | 1 + bin/tar.in | 12 ++ build-aux/build-guile.sh | 3 + configure | 6 + gash/gash.scm | 8 +- gash/tar.scm | 66 ++++++++ gash/ustar.scm | 318 +++++++++++++++++++++++++++++++++++++++ makefile | 10 +- 8 files changed, 416 insertions(+), 8 deletions(-) create mode 100644 bin/tar.in create mode 100644 gash/tar.scm create mode 100644 gash/ustar.scm diff --git a/.gitignore b/.gitignore index 197644b..8665b12 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ *.go *~ /bin/gash +/bin/tar /.config.make /doc/version.texi /gash/config.scm diff --git a/bin/tar.in b/bin/tar.in new file mode 100644 index 0000000..6c77072 --- /dev/null +++ b/bin/tar.in @@ -0,0 +1,12 @@ +#! /bin/sh +# -*-scheme-*- +exec ${GUILE-guile} -L $(dirname $0) -L $(dirname $(dirname $0)) -C $(dirname $0) -C $(dirname $(dirname $0)) --no-auto-compile -e '(tar)' -s $0 "$@" +!# +(define-module (tar) + #:export (main)) + +(set! %load-path (append '("@GUILE_SITE_DIR@") %load-path)) +(set! %load-compiled-path (append '("@GUILE_SITE_CCACHE_DIR@") %load-compiled-path)) + +(define (main args) + ((@ (gash tar) main) (command-line))) diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index b41d1ca..fd55c45 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -51,6 +51,8 @@ gash/job.scm gash/peg.scm gash/pipe.scm gash/script.scm +gash/tar.scm +gash/ustar.scm gash/util.scm " @@ -67,6 +69,7 @@ done SCRIPTS=" bin/gash +bin/tar " for i in $SCRIPTS; do diff --git a/configure b/configure index 35be694..f313ec5 100755 --- a/configure +++ b/configure @@ -34,6 +34,12 @@ sed \ -e s,@GUILE_SITE_CCACHE_DIR@,$GUILE_SITE_CCACHE_DIR,\ bin/gash.in > bin/gash chmod +x bin/gash +sed \ + -e s,@GUILE@,$GUILE,\ + -e s,@GUILE_SITE_DIR@,$GUILE_SITE_DIR,\ + -e s,@GUILE_SITE_CCACHE_DIR@,$GUILE_SITE_CCACHE_DIR,\ + bin/tar.in > bin/tar +chmod +x bin/tar cat > .config.make < +Copyright (C) 2016,2017,2018 R.E.W. van Beusekom +and others. -This is gash, Guile As SHell. Gash is free software and is covered by +This is Gash, Guile As SHell. Gash is free software and is covered by the GNU General Public License version 3 or later, see COPYING for the copyleft. - "))) (define (main args) diff --git a/gash/tar.scm b/gash/tar.scm new file mode 100644 index 0000000..1a71ce9 --- /dev/null +++ b/gash/tar.scm @@ -0,0 +1,66 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +(define-module (gash tar) + #:use-module (ice-9 getopt-long) + #:use-module (gash config) + #:use-module (gash ustar) + #:export (main)) + +(define (parse-opts args) + (let* ((option-spec + '((create (single-char #\c)) + (extract (single-char #\x)) + (file (single-char #\f) (value #t)) + (help (single-char #\h)) + (version (single-char #\V)))) + (options (getopt-long args option-spec)) + (create? (option-ref options 'create #f)) + (extract? (option-ref options 'extract #f)) + (help? (option-ref options 'help #f)) + (files (option-ref options '() '())) + (usage? (and (not help?) (not (or (and create? (pair? files)) extract?)))) + (version? (option-ref options 'version #f))) + + (or + (and version? + (format #t "tar (GASH) ~a\n" %version) + (exit 0)) + (and (or help? usage?) + (format (or (and usage? (current-error-port)) (current-output-port)) + (string-append "\ +Usage: tar [OPTION]... [FILE]... + -c, --create create a new archive + -e, --extract extract files from an archive + -f, --file=ARCHIVE use archive file or device ARCHIVE + -h, --help display this help + -V, --version display version +")) + (exit (or (and usage? 2) 0))) + options))) + +(define (main args) + (let* ((options (parse-opts args)) + (create? (option-ref options 'create #f)) + (extract? (option-ref options 'extract #f)) + (file (option-ref options 'file "/dev/stdout")) + (files (option-ref options '() '()))) + (cond (create? + (write-ustar-archive file files)) + (extract? + (read-ustar-archive file files))))) diff --git a/gash/ustar.scm b/gash/ustar.scm new file mode 100644 index 0000000..05c3b40 --- /dev/null +++ b/gash/ustar.scm @@ -0,0 +1,318 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2013 Mark H Weaver +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +(define-module (gash ustar) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:export (read-ustar-archive + write-ustar-archive)) + +(define (fmt-error fmt . args) + (error (apply format #f fmt args))) + +;; Like 'string-pad-right', but for bytevectors. However, unlike +;; 'string-pad-right', truncation is not allowed here. +(define* (bytevector-pad + bv len #:optional (byte 0) (start 0) (end (bytevector-length bv))) + (when (< len (- end start)) + (fmt-error + "bytevector-pad: truncation would occur: len ~a, start ~a, end ~a, bv ~s" + len start end bv)) + (let ((result (make-bytevector len byte))) + (bytevector-copy! bv start result 0 (- end start)) + result)) + +(define (bytevector-append . bvs) + (let* ((lengths (map bytevector-length bvs)) + (total (fold + 0 lengths)) + (result (make-bytevector total))) + (fold (lambda (bv len pos) + (bytevector-copy! bv 0 result pos len) + (+ pos len)) + 0 bvs lengths) + result)) + +(define ustar-charset + #; + (char-set-union (ucs-range->char-set #x20 #x23) + (ucs-range->char-set #x25 #x40) + (ucs-range->char-set #x41 #x5B) + (ucs-range->char-set #x5F #x60) + (ucs-range->char-set #x61 #x7B)) + char-set:ascii) + +(define (valid-ustar-char? c) + (char-set-contains? ustar-charset c)) + +(define (ustar-string n str name) + (unless (>= n (string-length str)) + (fmt-error "~a is too long (max ~a): ~a" name n str)) + (unless (string-every valid-ustar-char? str) + (fmt-error "~a contains unsupported character(s): ~s in ~s" + name + (string-filter (negate valid-ustar-char?) str) + str)) + (bytevector-pad (string->utf8 str) n)) + +(define (ustar-0string n str name) + (bytevector-pad (ustar-string (- n 1) str name) + n)) + +(define (ustar-number n num name) + (unless (and (integer? num) + (exact? num) + (not (negative? num))) + (fmt-error "~a is not a non-negative exact integer: ~a" name num)) + (unless (< num (expt 8 (- n 1))) + (fmt-error "~a is too large (max ~a): ~a" name (expt 8 (- n 1)) num)) + (bytevector-pad (string->utf8 (string-pad (number->string num 8) + (- n 1) + #\0)) + n)) + +(define (checksum-bv bv) + (let ((len (bytevector-length bv))) + (let loop ((i 0) (sum 0)) + (if (< i len) + (loop (+ i 1) (+ sum (bytevector-u8-ref bv i))) + sum)))) + +(define (checksum . bvs) + (fold + 0 (map checksum-bv bvs))) + +(define nuls (make-bytevector 512 0)) + +;; write a ustar record of exactly 512 bytes, starting with the +;; segment of BV between START (inclusive) and END (exclusive), and +;; padded at the end with nuls as needed. +(define* (write-ustar-record + port bv #:optional (start 0) (end (bytevector-length bv))) + (when (< 512 (- end start)) + (fmt-error "write-ustar-record: record too long: start ~s, end ~s, bv ~s" + start end bv)) + ;; We could have used 'bytevector-pad' here, + ;; but instead use a method that avoids allocation. + (put-bytevector port bv start end) + (put-bytevector port nuls 0 (- 512 (- end start)))) + +;; write 1024 zero bytes, which indicates the end of a ustar archive. +(define (write-ustar-footer port) + (put-bytevector port nuls) + (put-bytevector port nuls)) + +(define (compose-path-name dir name) + (if (or (string-null? dir) + (file-name-separator? (string-ref dir (- (string-length dir) 1)))) + (string-append dir name) + (string-append dir "/" name))) + +;; Like 'call-with-port', but also closes PORT if an error occurs. +(define (call-with-port* port proc) + (dynamic-wind + (lambda () #f) + (lambda () (proc port)) + (lambda () (close port)))) + +(define (call-with-dirstream* dirstream proc) + (dynamic-wind + (lambda () #f) + (lambda () (proc dirstream)) + (lambda () (closedir dirstream)))) + +(define (files-in-directory dir) + (call-with-dirstream* (opendir dir) + (lambda (dirstream) + (let loop ((files '())) + (let ((name (readdir dirstream))) + (cond ((eof-object? name) + (reverse files)) + ((member name '("." "..")) + (loop files)) + (else + (loop (cons (compose-path-name dir name) files))))))))) + +;; split the path into prefix and name fields for purposes of the +;; ustar header. If the entire path fits in the name field (100 chars +;; max), then leave the prefix empty. Otherwise, try to put the last +;; component into the name field and everything else into the prefix +;; field (155 chars max). If that fails, put as much as possible into +;; the prefix and the rest into the name field. This follows the +;; behavior of GNU tar when creating a ustar archive. +(define (ustar-path-name-split path orig-path) + (define (too-long) + (fmt-error "~a: file name too long" orig-path)) + (let ((len (string-length path))) + (cond ((<= len 100) (values "" path)) + ((> len 256) (too-long)) + ((string-rindex path + file-name-separator? + (- len 101) + (min (- len 1) 156)) + => (lambda (i) + (values (substring path 0 i) + (substring path (+ i 1) len)))) + (else (too-long))))) + +(define (write-ustar-header port path st) + (let* ((type (stat:type st)) + (perms (stat:perms st)) + (mtime (stat:mtime st)) + (uid (stat:uid st)) + (gid (stat:gid st)) + (uname (or (false-if-exception (passwd:name (getpwuid uid))) + "")) + (gname (or (false-if-exception (group:name (getgrgid gid))) + "")) + + (size (case type + ((regular) (stat:size st)) + (else 0))) + + (type-flag (case type + ((regular) "0") + ((symlink) "2") + ((char-special) "3") + ((block-special) "4") + ((directory) "5") + ((fifo) "6") + (else (fmt-error "~a: unsupported file type ~a" + path type)))) + + (link-name (case type + ((symlink) (readlink path)) + (else ""))) + + (dev-major (case type + ((char-special block-special) + (quotient (stat:rdev st) 256)) + (else 0))) + (dev-minor (case type + ((char-special block-special) + (remainder (stat:rdev st) 256)) + (else 0))) + + ;; Convert file name separators to slashes. + (slash-path (string-map (lambda (c) + (if (file-name-separator? c) #\/ c)) + path)) + + ;; Make the path name relative. + ;; TODO: handle drive letters on windows. + (relative-path (if (string-every #\/ slash-path) + "." + (string-trim slash-path #\/))) + + ;; If it's a directory, add a trailing slash, + ;; otherwise remove trailing slashes. + (full-path (case type + ((directory) (string-append relative-path "/")) + (else (string-trim-right relative-path #\/))))) + + (receive (prefix name) (ustar-path-name-split full-path path) + + (let* ((%name (ustar-string 100 name "file name")) + (%mode (ustar-number 8 perms "file mode")) + (%uid (ustar-number 8 uid "user id")) + (%gid (ustar-number 8 gid "group id")) + (%size (ustar-number 12 size "file size")) + (%mtime (ustar-number 12 mtime "modification time")) + (%type-flag (ustar-string 1 type-flag "type flag")) + (%link-name (ustar-string 100 link-name "link name")) + (%magic (ustar-0string 6 "ustar" "magic field")) + (%version (ustar-string 2 "00" "version number")) + (%uname (ustar-0string 32 uname "user name")) + (%gname (ustar-0string 32 gname "group name")) + (%dev-major (ustar-number 8 dev-major "dev major")) + (%dev-minor (ustar-number 8 dev-minor "dev minor")) + (%prefix (ustar-string 155 prefix "directory name")) + + (%dummy-checksum (string->utf8 " ")) + + (%checksum + (bytevector-append + (ustar-number + 7 + (checksum %name %mode %uid %gid %size %mtime + %dummy-checksum + %type-flag %link-name %magic %version + %uname %gname %dev-major %dev-minor + %prefix) + "checksum") + (string->utf8 " ")))) + + (write-ustar-record port + (bytevector-append + %name %mode %uid %gid %size %mtime + %checksum + %type-flag %link-name %magic %version + %uname %gname %dev-major %dev-minor + %prefix)))))) + +(define (write-ustar-path port path) + (let* ((path (if (string-every file-name-separator? path) + file-name-separator-string + (string-trim-right path file-name-separator?))) + (st (lstat path)) + (type (stat:type st)) + (size (stat:size st))) + (write-ustar-header port path st) + (case type + ((regular) + (call-with-port* (open-file path "rb") + (lambda (in) + (let ((buf (make-bytevector 512))) + (let loop ((left size)) + (when (positive? left) + (let* ((asked (min left 512)) + (obtained (get-bytevector-n! in buf 0 asked))) + (when (or (eof-object? obtained) + (< obtained asked)) + (fmt-error "~a: file appears to have shrunk" path)) + (write-ustar-record port buf 0 obtained) + (loop (- left obtained))))))))) + ((directory) + (for-each (lambda (path) (write-ustar-path port path)) + (files-in-directory path)))))) + +(define (read-ustar-archive) + (format (current-error-port) "TODO\n")) + +(define (write-ustar-archive output-path paths) + (catch #t + (lambda () + (call-with-port* (open-file output-path "wb") + (lambda (out) + (for-each (lambda (path) + (write-ustar-path out path)) + paths) + (write-ustar-footer out)))) + (lambda (key subr message args . rest) + (false-if-exception (delete-file output-path)) + (format (current-error-port) "ERROR: ~a\n" + (apply format #f message args)) + (exit 1)))) + +;;; Local Variables: +;;; mode: scheme +;;; eval: (put 'call-with-port* 'scheme-indent-function 1) +;;; eval: (put 'call-with-dirstream* 'scheme-indent-function 1) +;;; End: diff --git a/makefile b/makefile index d6bc588..8a081f5 100644 --- a/makefile +++ b/makefile @@ -4,12 +4,14 @@ default: all .config.make: makefile + +bin/gash: bin/gash.in | do-configure +bin/tar: bin/tar.in | do-configure + +do-configure: ./configure --prefix=$(PREFIX) -bin/gash: bin/gash.in - ./configure --prefix=$(PREFIX) - -all: all-go bin/gash +all: all-go do-configure all-go: build-aux/build-guile.sh From 70d28ea4804eeb4bd85fa7ff8fa6638d27f73a9b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 26 Oct 2018 15:52:20 +0200 Subject: [PATCH 161/312] Make tar a bournish-command. * bin/gash.in: Make Scheme script. * bin/tar.in: Likewise. * gash/bournish-commands (tar-command): New command, move from tar.scm. (%bournish-commands): Add it. * gash/tar.scm: Remove. --- bin/gash | 6 ++++ bin/gash.in | 28 +++++++++++----- bin/tar.in | 29 +++++++++++------ gash/bournish-commands.scm | 37 ++++++++++++++++++++- gash/gash.scm | 21 ++++++++++-- gash/tar.scm | 66 -------------------------------------- 6 files changed, 100 insertions(+), 87 deletions(-) create mode 100755 bin/gash delete mode 100644 gash/tar.scm diff --git a/bin/gash b/bin/gash new file mode 100755 index 0000000..736b298 --- /dev/null +++ b/bin/gash @@ -0,0 +1,6 @@ +#! /home/janneke/.guix-profile/bin/guile \ +--no-auto-compile -e main -L "/usr/local/share/guile/site/" -C "/usr/local/lib/guile//site-ccache" -L . -C . -s +!# +(define (main args) + (setenv "SHELL" ((compose canonicalize-path car command-line))) + ((@ (gash gash) main) (command-line))) diff --git a/bin/gash.in b/bin/gash.in index 672d98f..84bbe23 100644 --- a/bin/gash.in +++ b/bin/gash.in @@ -1,12 +1,24 @@ -#! /bin/sh -# -*-scheme-*- -exec ${GUILE-guile} -L $(dirname $0) -L $(dirname $(dirname $0)) -C $(dirname $0) -C $(dirname $(dirname $0)) --no-auto-compile -e '(gash)' -s $0 "$@" +#! @GUILE@ \ +--no-auto-compile -e main -L "@GUILE_SITE_DIR@" -C "@GUILE_SITE_CCACHE_DIR@" -L . -C . -s !# -(define-module (gash) - #:export (main)) - -(set! %load-path (append '("@GUILE_SITE_DIR@") %load-path)) -(set! %load-compiled-path (append '("@GUILE_SITE_CCACHE_DIR@") %load-compiled-path)) +;;; Gash --- Guile As SHell +;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . (define (main args) (setenv "SHELL" ((compose canonicalize-path car command-line))) diff --git a/bin/tar.in b/bin/tar.in index 6c77072..961d7c8 100644 --- a/bin/tar.in +++ b/bin/tar.in @@ -1,12 +1,23 @@ -#! /bin/sh -# -*-scheme-*- -exec ${GUILE-guile} -L $(dirname $0) -L $(dirname $(dirname $0)) -C $(dirname $0) -C $(dirname $(dirname $0)) --no-auto-compile -e '(tar)' -s $0 "$@" +#! @GUILE@ \ +--no-auto-compile -e main -L "@GUILE_SITE_DIR@" -C "@GUILE_SITE_CCACHE_DIR@" -L . -C . -s !# -(define-module (tar) - #:export (main)) - -(set! %load-path (append '("@GUILE_SITE_DIR@") %load-path)) -(set! %load-compiled-path (append '("@GUILE_SITE_CCACHE_DIR@") %load-compiled-path)) +;;; Gash --- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . (define (main args) - ((@ (gash tar) main) (command-line))) + ((@ (gash gash) main) (cons* (car (command-line)) "--" "tar" (cdr (command-line))))) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index b158e28..a2aa3bd 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -33,6 +33,7 @@ #:use-module (gash guix-build-utils) #:use-module (gash config) #:use-module (gash io) + #:use-module (gash ustar) #:use-module (gash util) #:export ( @@ -310,7 +311,7 @@ Options: (no-file-name (single-char #\h)) (only-matching (single-char #\o)) (version (single-char #\V)))) - (options (getopt-long (cons "ls" args) option-spec)) + (options (getopt-long (cons "grep" args) option-spec)) (help? (option-ref options 'help #f)) (version? (option-ref options 'version #f)) (files (option-ref options '() '()))) @@ -363,6 +364,39 @@ Options: (for-each display-match matches) 0))))))))) +(define (tar-command . args) + (lambda _ + (let* ((option-spec + '((create (single-char #\c)) + (extract (single-char #\x)) + (file (single-char #\f) (value #t)) + (help (single-char #\h)) + (version (single-char #\V)))) + (args (cons "tar" args)) + (options (getopt-long args option-spec)) + (create? (option-ref options 'create #f)) + (extract? (option-ref options 'extract #f)) + (file (option-ref options 'file "/dev/stdout")) + (files (option-ref options '() '())) + (help? (option-ref options 'help #f)) + (usage? (and (not help?) (not (or (and create? (pair? files)) extract?)))) + (version? (option-ref options 'version #f))) + (cond ((or help? usage?) (format (if usage? (current-error-port) #t) + "\ +Usage: tar [OPTION]... [FILE]... + -c, --create create a new archive + -f, --file=ARCHIVE use archive file or device ARCHIVE + -h, --help display this help + -V, --version display version + -x, --extract extract files from an archive +") + (exit (if usage? 2 0))) + (version? (format #t "tar (GASH) ~a\n" %version) (exit 0)) + (create? + (write-ustar-archive file files)) + (extract? + (read-ustar-archive file files)))))) + (define %bournish-commands `( ("cat" . ,cat-command) @@ -371,6 +405,7 @@ Options: ("grep" . ,grep-command) ("ls" . ,ls-command) ("reboot" . ,reboot-command) + ("tar" . ,tar-command) ("wc" . ,wc-command) ("which" . ,which-command) )) diff --git a/gash/gash.scm b/gash/gash.scm index 3193895..346e3ac 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -15,6 +15,8 @@ #:use-module (ice-9 regex) #:use-module (gash config) + #:use-module (gash builtins) + #:use-module (gash bournish-commands) #:use-module (gash environment) #:use-module (gash job) #:use-module (gash pipe) @@ -46,8 +48,11 @@ (call-with-input-file file-name parse)) (define (display-help) - (display "\ + (let ((builtins (sort (map car (append %bournish-commands ;;%builtin-commands + )) string<))) + (display (string-append "\ Usage: gash [OPTION]... [FILE]... + or gash [OPTION]... -- BUILTIN [ARG]... Options: -c, --command=STRING Evaluate STRING and exit @@ -59,7 +64,10 @@ Options: --prefer-builtins Use builtins, even if command is available in PATH -v, --version Display the version -x, --xtrace Print simple command trace -")) + +Builtins: + " (string-join builtins) " +")))) (define (display-version) (display (string-append " @@ -86,7 +94,9 @@ copyleft. (geesh (single-char #\g)) (version (single-char #\v)) (xtrace (single-char #\x)))) - (options (getopt-long args option-spec #:stop-at-first-non-option #t )) + (builtin-command-line (and=> (member "--" args) cdr)) + (args (take-while (negate (cut equal? <> "--")) args)) + (options (getopt-long args option-spec #:stop-at-first-non-option #t)) (command? (option-ref options 'command #f)) (opt? (lambda (name) (lambda (o) (and (eq? (car o) name) (cdr o))))) (debug (length (filter-map (opt? 'debug) options))) @@ -113,6 +123,11 @@ copyleft. (if parse? (map pretty-print asts) (for-each run asts)) (exit (script-status)))) + (builtin-command-line + (let* ((builtin (car builtin-command-line)) + (args (cdr builtin-command-line)) + (command (assoc-ref %bournish-commands builtin))) + ((apply command args)))) (#t (let* ((HOME (string-append (getenv "HOME") "/.gash_history")) (thunk (lambda () (let loop ((line (readline (prompt)))) diff --git a/gash/tar.scm b/gash/tar.scm deleted file mode 100644 index 1a71ce9..0000000 --- a/gash/tar.scm +++ /dev/null @@ -1,66 +0,0 @@ -;;; Gash --- Guile As SHell -;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen -;;; -;;; This file is part of Gash. -;;; -;;; Gash is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; Gash is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with Gash. If not, see . - -(define-module (gash tar) - #:use-module (ice-9 getopt-long) - #:use-module (gash config) - #:use-module (gash ustar) - #:export (main)) - -(define (parse-opts args) - (let* ((option-spec - '((create (single-char #\c)) - (extract (single-char #\x)) - (file (single-char #\f) (value #t)) - (help (single-char #\h)) - (version (single-char #\V)))) - (options (getopt-long args option-spec)) - (create? (option-ref options 'create #f)) - (extract? (option-ref options 'extract #f)) - (help? (option-ref options 'help #f)) - (files (option-ref options '() '())) - (usage? (and (not help?) (not (or (and create? (pair? files)) extract?)))) - (version? (option-ref options 'version #f))) - - (or - (and version? - (format #t "tar (GASH) ~a\n" %version) - (exit 0)) - (and (or help? usage?) - (format (or (and usage? (current-error-port)) (current-output-port)) - (string-append "\ -Usage: tar [OPTION]... [FILE]... - -c, --create create a new archive - -e, --extract extract files from an archive - -f, --file=ARCHIVE use archive file or device ARCHIVE - -h, --help display this help - -V, --version display version -")) - (exit (or (and usage? 2) 0))) - options))) - -(define (main args) - (let* ((options (parse-opts args)) - (create? (option-ref options 'create #f)) - (extract? (option-ref options 'extract #f)) - (file (option-ref options 'file "/dev/stdout")) - (files (option-ref options '() '()))) - (cond (create? - (write-ustar-archive file files)) - (extract? - (read-ustar-archive file files))))) From 904eecbb2cb09f89eefcc644dad34b36725f37fd Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 26 Oct 2018 16:22:58 +0200 Subject: [PATCH 162/312] Expose all bournish commands as external command. * bin/builtin.in: New file. * bin/tar.in: Remove. * configure: Generate bin/ for all bournish-commands. * build-aux/build-guile.sh: Compile them. * .gitignore: Ignore them. --- .gitignore | 8 ++++++++ bin/{tar.in => builtin.in} | 2 +- bin/gash | 6 ------ build-aux/build-guile.sh | 9 ++++++++- configure | 26 ++++++++++++++++++++------ 5 files changed, 37 insertions(+), 14 deletions(-) rename bin/{tar.in => builtin.in} (90%) delete mode 100755 bin/gash diff --git a/.gitignore b/.gitignore index 8665b12..8f42809 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,15 @@ *.go *~ +/bin/cat +/bin/cp +/bin/find /bin/gash +/bin/grep +/bin/ls +/bin/reboot /bin/tar +/bin/wc +/bin/which /.config.make /doc/version.texi /gash/config.scm diff --git a/bin/tar.in b/bin/builtin.in similarity index 90% rename from bin/tar.in rename to bin/builtin.in index 961d7c8..0ef6eba 100644 --- a/bin/tar.in +++ b/bin/builtin.in @@ -20,4 +20,4 @@ ;;; along with Gash. If not, see . (define (main args) - ((@ (gash gash) main) (cons* (car (command-line)) "--" "tar" (cdr (command-line))))) + ((@ (gash gash) main) (cons* (car (command-line)) "--" "@builtin@" (cdr (command-line))))) diff --git a/bin/gash b/bin/gash deleted file mode 100755 index 736b298..0000000 --- a/bin/gash +++ /dev/null @@ -1,6 +0,0 @@ -#! /home/janneke/.guix-profile/bin/guile \ ---no-auto-compile -e main -L "/usr/local/share/guile/site/" -C "/usr/local/lib/guile//site-ccache" -L . -C . -s -!# -(define (main args) - (setenv "SHELL" ((compose canonicalize-path car command-line))) - ((@ (gash gash) main) (command-line))) diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index fd55c45..9dbe8ec 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -51,7 +51,6 @@ gash/job.scm gash/peg.scm gash/pipe.scm gash/script.scm -gash/tar.scm gash/ustar.scm gash/util.scm " @@ -68,8 +67,16 @@ for i in $SCM_FILES; do done SCRIPTS=" +bin/cat +bin/cp +bin/find bin/gash +bin/grep +bin/ls +bin/reboot bin/tar +bin/wc +bin/which " for i in $SCRIPTS; do diff --git a/configure b/configure index f313ec5..a8dd2b6 100755 --- a/configure +++ b/configure @@ -34,12 +34,26 @@ sed \ -e s,@GUILE_SITE_CCACHE_DIR@,$GUILE_SITE_CCACHE_DIR,\ bin/gash.in > bin/gash chmod +x bin/gash -sed \ - -e s,@GUILE@,$GUILE,\ - -e s,@GUILE_SITE_DIR@,$GUILE_SITE_DIR,\ - -e s,@GUILE_SITE_CCACHE_DIR@,$GUILE_SITE_CCACHE_DIR,\ - bin/tar.in > bin/tar -chmod +x bin/tar +BUILTINS=" +cat +cp +find +grep +ls +reboot +tar +wc +which +" +for builtin in $BUILTINS; do + sed \ + -e s,@GUILE@,$GUILE,\ + -e s,@GUILE_SITE_DIR@,$GUILE_SITE_DIR,\ + -e s,@GUILE_SITE_CCACHE_DIR@,$GUILE_SITE_CCACHE_DIR,\ + -e s,@builtin@,$builtin,\ + bin/builtin.in > bin/$builtin + chmod +x bin/$builtin +done cat > .config.make < Date: Fri, 26 Oct 2018 22:40:13 +0200 Subject: [PATCH 163/312] Add delete-file-recursively. * gash/guix-build-utils.scm (delete-file-recursively): New function, import from Guix. --- gash/guix-build-utils.scm | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/gash/guix-build-utils.scm b/gash/guix-build-utils.scm index 5e60386..c010543 100644 --- a/gash/guix-build-utils.scm +++ b/gash/guix-build-utils.scm @@ -25,12 +25,14 @@ #:use-module (srfi srfi-9 gnu) #:use-module (ice-9 ftw) + #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:export ( + delete-file-recursively dump-port file-name-predicate find-files @@ -130,6 +132,31 @@ also be included. If FAIL-ON-ERROR? is true, raise an exception upon error." stat) string Date: Fri, 26 Oct 2018 22:41:01 +0200 Subject: [PATCH 164/312] Add mkdir-p. * gash/guix-build-utils.scm (mkdir-p): New function, import from Guix. --- gash/guix-build-utils.scm | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/gash/guix-build-utils.scm b/gash/guix-build-utils.scm index c010543..340bec6 100644 --- a/gash/guix-build-utils.scm +++ b/gash/guix-build-utils.scm @@ -44,6 +44,7 @@ grep-match-line grep-match-column grep-match-end-column + mkdir-p directory-exists? executable-file? @@ -212,3 +213,28 @@ transferred and the continuation of the transfer as a thunk." (lambda (in) (grep* pattern #:port in #:file-name file)))) (else (grep* pattern)))) + +(define (mkdir-p dir) + "Create directory DIR and all its ancestors." + (define absolute? + (string-prefix? "/" dir)) + + (define not-slash + (char-set-complement (char-set #\/))) + + (let loop ((components (string-tokenize dir not-slash)) + (root (if absolute? + "" + "."))) + (match components + ((head tail ...) + (let ((path (string-append root "/" head))) + (catch 'system-error + (lambda () + (mkdir path) + (loop tail path)) + (lambda args + (if (= EEXIST (system-error-errno args)) + (loop tail path) + (apply throw args)))))) + (() #t)))) From 92d289613408867c9b8afa3da12abd492c52de60 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 26 Oct 2018 19:36:41 +0200 Subject: [PATCH 165/312] tar: Support extraction. * gash/ustar.scm (extract-ustar-file): * gash/ustar.scm (): New record type. (bv->ustar-string, bv->ustar-number, bv->ustar-0string, sub-bytevector, read-ustar-header, extract-ustar-file): New function. Implement extraction. --- gash/bournish-commands.scm | 2 +- gash/ustar.scm | 249 ++++++++++++++++++++++++++++++------- 2 files changed, 207 insertions(+), 44 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index a2aa3bd..a718803 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -395,7 +395,7 @@ Usage: tar [OPTION]... [FILE]... (create? (write-ustar-archive file files)) (extract? - (read-ustar-archive file files)))))) + (extract-ustar-archive file files)))))) (define %bournish-commands `( diff --git a/gash/ustar.scm b/gash/ustar.scm index 05c3b40..4fd4330 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -19,11 +19,14 @@ (define-module (gash ustar) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 receive) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) - #:export (read-ustar-archive + #:use-module (gash guix-build-utils) + #:export (extract-ustar-archive write-ustar-archive)) (define (fmt-error fmt . args) @@ -92,15 +95,18 @@ (define (checksum-bv bv) (let ((len (bytevector-length bv))) (let loop ((i 0) (sum 0)) - (if (< i len) - (loop (+ i 1) (+ sum (bytevector-u8-ref bv i))) - sum)))) + (if (= i len) sum + (loop (+ i 1) (+ sum (bytevector-u8-ref bv i))))))) (define (checksum . bvs) (fold + 0 (map checksum-bv bvs))) (define nuls (make-bytevector 512 0)) +;; read a ustar record of exactly 512 bytes. +(define (read-ustar-record port) + (get-bytevector-n port 512)) + ;; write a ustar record of exactly 512 bytes, starting with the ;; segment of BV between START (inclusive) and END (exclusive), and ;; padded at the end with nuls as needed. @@ -172,6 +178,129 @@ (substring path (+ i 1) len)))) (else (too-long))))) +(define (bv->ustar-string bv name) + (string-trim-right (bv->ustar-0string bv name) (compose zero? char->integer))) + +(define (bv->ustar-number bv name) + (let ((string (bv->ustar-string bv name))) + (or (string->number string 8) 0))) + +(define (bv->ustar-0string bv name) + (bytevector->string bv (make-transcoder (latin-1-codec)))) + +(define-immutable-record-type + (make-ustar-header name + mode + uid + gid + size + mtime + checksum + ;; space + type-flag + link-name + magic + version + uname + gname + dev-major + dev-minor + prefix) + ustar-header? + (name ustar-header-name ) + (mode ustar-header-mode ) + (uid ustar-header-uid ) + (gid ustar-header-gid ) + (size ustar-header-size ) + (mtime ustar-header-mtime ) + (checksum ustar-header-checksum ) + ;;(space ustar-header-space ) + (type-flag ustar-header-type-flag) + (link-name ustar-header-link-name) + (magic ustar-header-magic ) + (version ustar-header-version ) + (uname ustar-header-uname ) + (gname ustar-header-gname ) + (dev-major ustar-header-dev-major) + (dev-minor ustar-header-dev-minor) + (prefix ustar-header-prefix )) + +(define ustar-header-field-size-alist + '((name . 100) + (mode . 8) + (uid . 8) + (gid . 8) + (size . 12) + (mtime . 12) + (checksum . 7) + (space . 1) + (type-flag . 1) + (link-name . 100) + (magic . 6) + (version . 2) + (uname . 32) + (gname . 32) + (dev-major . 8) + (dev-minor . 8) + (prefix . 155))) + +(define (ustar-footer? bv) + (every zero? (array->list bv))) + +(define (sub-bytevector bv offset size) + (let ((sub (make-bytevector size))) + (bytevector-copy! bv offset sub 0 size) + sub)) + +(define (read-ustar-header port) + (define offset + (let ((offset 0)) + (lambda (. args) + (if (null? args) offset + (let ((n (car args))) + (set! offset (+ offset n)) + n))))) + (let ((%record (read-ustar-record port))) + (and (not (eof-object? %record)) + (not (ustar-footer? %record)) + (let* ((field-bv-alist + `((dummy-checksum . ,(string->utf8 " ")) + ,@(map + (match-lambda ((field . size) + (cons field (sub-bytevector %record (offset) (offset size))))) + ustar-header-field-size-alist))) + (checksum-fields '(name mode uid gid size mtime + dummy-checksum + type-flag link-name magic version + uname gname dev-major dev-minor + prefix)) + (checksum (apply checksum (map (cut assoc-ref field-bv-alist <>) + checksum-fields))) + (header + (make-ustar-header + (bv->ustar-string (assoc-ref field-bv-alist 'name ) "file name" ) + (bv->ustar-number (assoc-ref field-bv-alist 'mode ) "file mode" ) + (bv->ustar-number (assoc-ref field-bv-alist 'uid ) "user id" ) + (bv->ustar-number (assoc-ref field-bv-alist 'gid ) "group id" ) + (bv->ustar-number (assoc-ref field-bv-alist 'size ) "file size" ) + (bv->ustar-number (assoc-ref field-bv-alist 'mtime ) "modification time") + (bv->ustar-number (assoc-ref field-bv-alist 'checksum ) "checksum" ) + ;; (bv->ustar-string (assoc-ref field-bv-alist 'space ) "space" ) + (bv->ustar-string (assoc-ref field-bv-alist 'type-flag) "type flag" ) + (bv->ustar-string (assoc-ref field-bv-alist 'link-name) "link name" ) + (bv->ustar-string (assoc-ref field-bv-alist 'magic ) "magic field" ) + (bv->ustar-string (assoc-ref field-bv-alist 'version ) "version number" ) + (bv->ustar-string (assoc-ref field-bv-alist 'uname ) "user name" ) + (bv->ustar-string (assoc-ref field-bv-alist 'gname ) "group name" ) + (bv->ustar-number (assoc-ref field-bv-alist 'dev-major) "dev major" ) + (bv->ustar-number (assoc-ref field-bv-alist 'dev-minor) "dev minor" ) + (bv->ustar-string (assoc-ref field-bv-alist 'prefix ) "directory name" )))) + (when (not (= (ustar-header-checksum header) checksum)) + (error "checksum mismatch, expected: ~s, got: ~s\n" + (ustar-header-checksum header) + checksum)) + header)))) + (define (write-ustar-header port path st) (let* ((type (stat:type st)) (perms (stat:perms st)) @@ -188,11 +317,11 @@ (else 0))) (type-flag (case type - ((regular) "0") - ((symlink) "2") + ((regular) "0") + ((symlink) "2") ((char-special) "3") ((block-special) "4") - ((directory) "5") + ((directory) "5") ((fifo) "6") (else (fmt-error "~a: unsupported file type ~a" path type)))) @@ -229,43 +358,43 @@ (receive (prefix name) (ustar-path-name-split full-path path) - (let* ((%name (ustar-string 100 name "file name")) - (%mode (ustar-number 8 perms "file mode")) - (%uid (ustar-number 8 uid "user id")) - (%gid (ustar-number 8 gid "group id")) - (%size (ustar-number 12 size "file size")) - (%mtime (ustar-number 12 mtime "modification time")) - (%type-flag (ustar-string 1 type-flag "type flag")) - (%link-name (ustar-string 100 link-name "link name")) - (%magic (ustar-0string 6 "ustar" "magic field")) - (%version (ustar-string 2 "00" "version number")) - (%uname (ustar-0string 32 uname "user name")) - (%gname (ustar-0string 32 gname "group name")) - (%dev-major (ustar-number 8 dev-major "dev major")) - (%dev-minor (ustar-number 8 dev-minor "dev minor")) - (%prefix (ustar-string 155 prefix "directory name")) + (let* ((%name (ustar-string 100 name "file name")) + (%mode (ustar-number 8 perms "file mode")) + (%uid (ustar-number 8 uid "user id")) + (%gid (ustar-number 8 gid "group id")) + (%size (ustar-number 12 size "file size")) + (%mtime (ustar-number 12 mtime "modification time")) + (%type-flag (ustar-string 1 type-flag "type flag")) + (%link-name (ustar-string 100 link-name "link name")) + (%magic (ustar-0string 6 "ustar" "magic field")) + (%version (ustar-string 2 "00" "version number")) + (%uname (ustar-0string 32 uname "user name")) + (%gname (ustar-0string 32 gname "group name")) + (%dev-major (ustar-number 8 dev-major "dev major")) + (%dev-minor (ustar-number 8 dev-minor "dev minor")) + (%prefix (ustar-string 155 prefix "directory name")) - (%dummy-checksum (string->utf8 " ")) + (%dummy-checksum (string->utf8 " ")) - (%checksum - (bytevector-append - (ustar-number - 7 - (checksum %name %mode %uid %gid %size %mtime - %dummy-checksum - %type-flag %link-name %magic %version - %uname %gname %dev-major %dev-minor - %prefix) - "checksum") - (string->utf8 " ")))) + (%checksum + (bytevector-append + (ustar-number + 7 + (checksum %name %mode %uid %gid %size %mtime + %dummy-checksum + %type-flag %link-name %magic %version + %uname %gname %dev-major %dev-minor + %prefix) + "checksum") + (string->utf8 " ")))) - (write-ustar-record port - (bytevector-append - %name %mode %uid %gid %size %mtime - %checksum - %type-flag %link-name %magic %version - %uname %gname %dev-major %dev-minor - %prefix)))))) + (write-ustar-record port + (bytevector-append + %name %mode %uid %gid %size %mtime + %checksum + %type-flag %link-name %magic %version + %uname %gname %dev-major %dev-minor + %prefix)))))) (define (write-ustar-path port path) (let* ((path (if (string-every file-name-separator? path) @@ -293,8 +422,42 @@ (for-each (lambda (path) (write-ustar-path port path)) (files-in-directory path)))))) -(define (read-ustar-archive) - (format (current-error-port) "TODO\n")) +(define (extract-ustar-file port header) + (let* ((size (ustar-header-size header)) + (name (ustar-header-name header)) + (prefix (ustar-header-prefix header)) + (file-name (if (string-null? prefix) name + (string-append prefix "/" name))) + (dir (dirname file-name))) + (mkdir-p dir) + (with-output-to-file file-name + (lambda _ + (let loop ((record (read-ustar-record port)) (wrote 0)) + (let* ((read (+ wrote 512)) + (block (if (< read size) record + (sub-bytevector record 0 (- size wrote))))) + (display (bv->ustar-0string block "block")) + (and (not (eof-object? record)) + (< read size) + (loop (read-ustar-record port) read)))))) + (chmod file-name (ustar-header-mode header)) + (let ((mtime (ustar-header-mtime header))) + (utime file-name mtime mtime)))) + +(define (extract-ustar-archive file-name files) + (catch #t + (lambda () + (call-with-port* (open-file file-name "rb") + (lambda (in) + (let loop ((header (read-ustar-header in))) + (when (and header + (not (eof-object? header))) + (extract-ustar-file in header) + (loop (read-ustar-header in))))))) + (lambda (key subr message args . rest) + (format (current-error-port) "ERROR: ~a\n" + (apply format #f message args)) + (exit 1)))) (define (write-ustar-archive output-path paths) (catch #t From 463b71acc92e0d9e9400dbaec1625a2229f006f0 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 26 Oct 2018 22:55:51 +0200 Subject: [PATCH 166/312] tar: Support creation of deterministic archives. * gash/ustar.scm (write-ustar-header, write-ustar-file): Accept keyword arguments: group mtime numeric-owner? owner. (create-ustar-archive): Likewise. Rename from write-ustar-archive. * gash/bournish-commands.scm (tar-command): Support --group, --mtime, --numeric-owner, --owner and --sort. --- gash/bournish-commands.scm | 35 +++++++++-- gash/ustar.scm | 115 +++++++++++++++++++------------------ 2 files changed, 87 insertions(+), 63 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index a718803..f63efd1 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -368,9 +368,14 @@ Options: (lambda _ (let* ((option-spec '((create (single-char #\c)) + (group (value #t)) (extract (single-char #\x)) (file (single-char #\f) (value #t)) (help (single-char #\h)) + (mtime (value #t)) + (numeric-owner?) + (owner (value #t)) + (sort (value #t)) (version (single-char #\V)))) (args (cons "tar" args)) (options (getopt-long args option-spec)) @@ -384,16 +389,34 @@ Options: (cond ((or help? usage?) (format (if usage? (current-error-port) #t) "\ Usage: tar [OPTION]... [FILE]... - -c, --create create a new archive - -f, --file=ARCHIVE use archive file or device ARCHIVE - -h, --help display this help - -V, --version display version - -x, --extract extract files from an archive + -c, --create create a new archive + -f, --file=ARCHIVE use archive file or device ARCHIVE + --group=NAME force NAME as group for added files + -h, --help display this help + --mtime=DATE-OR-FILE set mtime for added files from DATE-OR-FILE + --numeric-owner always use numbers for user/group names + --owner=NAME force NAME as owner for added files + --sort=ORDER directory sorting order: none (default), name or + inode + -V, --version display version + -x, --extract extract files from an archive ") (exit (if usage? 2 0))) (version? (format #t "tar (GASH) ~a\n" %version) (exit 0)) (create? - (write-ustar-archive file files)) + (let ((files (if (not (option-ref options 'sort #f)) files + (sort files string<))) + (group (and=> (option-ref options 'group #f) string->number)) + (mtime (and=> (option-ref options 'mtime #f) string->number)) + (numeric-owner? (option-ref options 'numeric-owner? #f)) + (owner (and=> (option-ref options 'owner #f) string->number))) + (apply create-ustar-archive + `(,file + ,files + ,@(if group `(#:group ,group) '()) + ,@(if mtime `(#:mtime ,mtime) '()) + ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) + ,@(if owner `(#:owner ,owner) '()))))) (extract? (extract-ustar-archive file files)))))) diff --git a/gash/ustar.scm b/gash/ustar.scm index 4fd4330..3775314 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -27,7 +27,7 @@ #:use-module (rnrs io ports) #:use-module (gash guix-build-utils) #:export (extract-ustar-archive - write-ustar-archive)) + create-ustar-archive)) (define (fmt-error fmt . args) (error (apply format #f fmt args))) @@ -37,9 +37,9 @@ (define* (bytevector-pad bv len #:optional (byte 0) (start 0) (end (bytevector-length bv))) (when (< len (- end start)) - (fmt-error - "bytevector-pad: truncation would occur: len ~a, start ~a, end ~a, bv ~s" - len start end bv)) + (fmt-error + "bytevector-pad: truncation would occur: len ~a, start ~a, end ~a, bv ~s" + len start end bv)) (let ((result (make-bytevector len byte))) (bytevector-copy! bv start result 0 (- end start)) result)) @@ -57,10 +57,10 @@ (define ustar-charset #; (char-set-union (ucs-range->char-set #x20 #x23) - (ucs-range->char-set #x25 #x40) - (ucs-range->char-set #x41 #x5B) - (ucs-range->char-set #x5F #x60) - (ucs-range->char-set #x61 #x7B)) + (ucs-range->char-set #x25 #x40) + (ucs-range->char-set #x41 #x5B) + (ucs-range->char-set #x5F #x60) + (ucs-range->char-set #x61 #x7B)) char-set:ascii) (define (valid-ustar-char? c) @@ -68,12 +68,12 @@ (define (ustar-string n str name) (unless (>= n (string-length str)) - (fmt-error "~a is too long (max ~a): ~a" name n str)) + (fmt-error "~a is too long (max ~a): ~a" name n str)) (unless (string-every valid-ustar-char? str) - (fmt-error "~a contains unsupported character(s): ~s in ~s" - name - (string-filter (negate valid-ustar-char?) str) - str)) + (fmt-error "~a contains unsupported character(s): ~s in ~s" + name + (string-filter (negate valid-ustar-char?) str) + str)) (bytevector-pad (string->utf8 str) n)) (define (ustar-0string n str name) @@ -84,9 +84,9 @@ (unless (and (integer? num) (exact? num) (not (negative? num))) - (fmt-error "~a is not a non-negative exact integer: ~a" name num)) + (fmt-error "~a is not a non-negative exact integer: ~a" name num)) (unless (< num (expt 8 (- n 1))) - (fmt-error "~a is too large (max ~a): ~a" name (expt 8 (- n 1)) num)) + (fmt-error "~a is too large (max ~a): ~a" name (expt 8 (- n 1)) num)) (bytevector-pad (string->utf8 (string-pad (number->string num 8) (- n 1) #\0)) @@ -113,8 +113,8 @@ (define* (write-ustar-record port bv #:optional (start 0) (end (bytevector-length bv))) (when (< 512 (- end start)) - (fmt-error "write-ustar-record: record too long: start ~s, end ~s, bv ~s" - start end bv)) + (fmt-error "write-ustar-record: record too long: start ~s, end ~s, bv ~s" + start end bv)) ;; We could have used 'bytevector-pad' here, ;; but instead use a method that avoids allocation. (put-bytevector port bv start end) @@ -134,15 +134,15 @@ ;; Like 'call-with-port', but also closes PORT if an error occurs. (define (call-with-port* port proc) (dynamic-wind - (lambda () #f) - (lambda () (proc port)) - (lambda () (close port)))) + (lambda () #f) + (lambda () (proc port)) + (lambda () (close port)))) (define (call-with-dirstream* dirstream proc) (dynamic-wind - (lambda () #f) - (lambda () (proc dirstream)) - (lambda () (closedir dirstream)))) + (lambda () #f) + (lambda () (proc dirstream)) + (lambda () (closedir dirstream)))) (define (files-in-directory dir) (call-with-dirstream* (opendir dir) @@ -301,12 +301,12 @@ checksum)) header)))) -(define (write-ustar-header port path st) +(define* (write-ustar-header port path st #:key group mtime numeric-owner? owner) (let* ((type (stat:type st)) (perms (stat:perms st)) - (mtime (stat:mtime st)) - (uid (stat:uid st)) - (gid (stat:gid st)) + (mtime (or mtime (stat:mtime st))) + (uid (or owner (stat:uid st))) + (gid (or group (stat:gid st))) (uname (or (false-if-exception (passwd:name (getpwuid uid))) "")) (gname (or (false-if-exception (group:name (getgrgid gid))) @@ -396,31 +396,31 @@ %uname %gname %dev-major %dev-minor %prefix)))))) -(define (write-ustar-path port path) - (let* ((path (if (string-every file-name-separator? path) - file-name-separator-string - (string-trim-right path file-name-separator?))) - (st (lstat path)) +(define* (write-ustar-file port file-name #:key group mtime numeric-owner? owner) + (let* ((file-name (if (string-every file-name-separator? file-name) + file-name-separator-string + (string-trim-right file-name file-name-separator?))) + (st (lstat file-name)) (type (stat:type st)) (size (stat:size st))) - (write-ustar-header port path st) + (write-ustar-header port file-name st #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner) (case type ((regular) - (call-with-port* (open-file path "rb") + (call-with-port* (open-file file-name "rb") (lambda (in) (let ((buf (make-bytevector 512))) (let loop ((left size)) (when (positive? left) - (let* ((asked (min left 512)) - (obtained (get-bytevector-n! in buf 0 asked))) - (when (or (eof-object? obtained) - (< obtained asked)) - (fmt-error "~a: file appears to have shrunk" path)) - (write-ustar-record port buf 0 obtained) - (loop (- left obtained))))))))) + (let* ((asked (min left 512)) + (obtained (get-bytevector-n! in buf 0 asked))) + (when (or (eof-object? obtained) + (< obtained asked)) + (fmt-error "~a: file appears to have shrunk" file-name)) + (write-ustar-record port buf 0 obtained) + (loop (- left obtained))))))))) ((directory) - (for-each (lambda (path) (write-ustar-path port path)) - (files-in-directory path)))))) + (for-each (lambda (file-name) (write-ustar-file port file-name)) + (files-in-directory file-name)))))) (define (extract-ustar-file port header) (let* ((size (ustar-header-size header)) @@ -459,20 +459,21 @@ (apply format #f message args)) (exit 1)))) -(define (write-ustar-archive output-path paths) - (catch #t - (lambda () - (call-with-port* (open-file output-path "wb") - (lambda (out) - (for-each (lambda (path) - (write-ustar-path out path)) - paths) - (write-ustar-footer out)))) - (lambda (key subr message args . rest) - (false-if-exception (delete-file output-path)) - (format (current-error-port) "ERROR: ~a\n" - (apply format #f message args)) - (exit 1)))) +(define* (create-ustar-archive file-name files #:key group mtime numeric-owner? owner) + (catch 'fubar + (lambda () + (call-with-port* (open-file file-name "wb") + (lambda (out) + (for-each + (cut write-ustar-file out <> + #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner) + files) + (write-ustar-footer out)))) + (lambda (key subr message args . rest) + (false-if-exception (delete-file file-name)) + (format (current-error-port) "ERROR: ~a\n" + (apply format #f message args)) + (exit 1)))) ;;; Local Variables: ;;; mode: scheme From 28d62b616997933ed7fa8c8c80da88044b90098d Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 27 Oct 2018 00:42:50 +0200 Subject: [PATCH 167/312] tar: Support --list and --verbose. * gash/ustar.scm (extract-ustar-file): Add keyword argument: extract? (extract-ustar-archive): Add keyword arguments: extract?, verbose?: (display-rwx, display-header, list-ustar-archive): New function * gash/bournish-commands.scm (tar-command): Support --list, --verbose. --- gash/bournish-commands.scm | 25 ++++++-- gash/ustar.scm | 120 ++++++++++++++++++++++++------------- 2 files changed, 100 insertions(+), 45 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index f63efd1..1d13941 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -364,6 +364,10 @@ Options: (for-each display-match matches) 0))))))))) +(define (multi-opt options name) + (let ((opt? (lambda (o) (and (eq? (car o) name) (cdr o))))) + (filter-map opt? options))) + (define (tar-command . args) (lambda _ (let* ((option-spec @@ -373,19 +377,24 @@ Options: (file (single-char #\f) (value #t)) (help (single-char #\h)) (mtime (value #t)) + (list (single-char #\t)) (numeric-owner?) (owner (value #t)) (sort (value #t)) - (version (single-char #\V)))) + (verbose (single-char #\v)) + (version (single-char #\V)))) (args (cons "tar" args)) (options (getopt-long args option-spec)) (create? (option-ref options 'create #f)) + (list? (option-ref options 'list #f)) (extract? (option-ref options 'extract #f)) (file (option-ref options 'file "/dev/stdout")) (files (option-ref options '() '())) (help? (option-ref options 'help #f)) - (usage? (and (not help?) (not (or (and create? (pair? files)) extract?)))) - (version? (option-ref options 'version #f))) + (usage? (and (not help?) (not (or (and create? (pair? files)) + extract? list?)))) + (verbosity (length (multi-opt options 'verbose))) + (version? (option-ref options 'version #f))) (cond ((or help? usage?) (format (if usage? (current-error-port) #t) "\ Usage: tar [OPTION]... [FILE]... @@ -398,7 +407,9 @@ Usage: tar [OPTION]... [FILE]... --owner=NAME force NAME as owner for added files --sort=ORDER directory sorting order: none (default), name or inode + -t, --list list the contents of an archive -V, --version display version + -v, --verbose verbosely list files processed -x, --extract extract files from an archive ") (exit (if usage? 2 0))) @@ -416,9 +427,13 @@ Usage: tar [OPTION]... [FILE]... ,@(if group `(#:group ,group) '()) ,@(if mtime `(#:mtime ,mtime) '()) ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) - ,@(if owner `(#:owner ,owner) '()))))) + ,@(if owner `(#:owner ,owner) '()) + ,@(if owner `(#:owner ,owner) '()) + #:verbosity ,verbosity)))) (extract? - (extract-ustar-archive file files)))))) + (extract-ustar-archive file files #:verbosity verbosity)) + (list? + (list-ustar-archive file files #:verbosity (1+ verbosity))))))) (define %bournish-commands `( diff --git a/gash/ustar.scm b/gash/ustar.scm index 3775314..6271e74 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -26,8 +26,9 @@ #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (gash guix-build-utils) - #:export (extract-ustar-archive - create-ustar-archive)) + #:export (create-ustar-archive + extract-ustar-archive + list-ustar-archive)) (define (fmt-error fmt . args) (error (apply format #f fmt args))) @@ -396,7 +397,7 @@ %uname %gname %dev-major %dev-minor %prefix)))))) -(define* (write-ustar-file port file-name #:key group mtime numeric-owner? owner) +(define* (write-ustar-file port file-name #:key group mtime numeric-owner? owner verbosity) (let* ((file-name (if (string-every file-name-separator? file-name) file-name-separator-string (string-trim-right file-name file-name-separator?))) @@ -422,51 +423,70 @@ (for-each (lambda (file-name) (write-ustar-file port file-name)) (files-in-directory file-name)))))) -(define (extract-ustar-file port header) +(define (ustar-header-file-name header) + (let ((name (ustar-header-name header)) + (prefix (ustar-header-prefix header))) + (if (string-null? prefix) name + (string-append prefix "/" name)))) + +(define* (extract-ustar-file port header #:key (extract? #t)) (let* ((size (ustar-header-size header)) - (name (ustar-header-name header)) - (prefix (ustar-header-prefix header)) - (file-name (if (string-null? prefix) name - (string-append prefix "/" name))) - (dir (dirname file-name))) - (mkdir-p dir) - (with-output-to-file file-name - (lambda _ - (let loop ((record (read-ustar-record port)) (wrote 0)) - (let* ((read (+ wrote 512)) - (block (if (< read size) record - (sub-bytevector record 0 (- size wrote))))) - (display (bv->ustar-0string block "block")) - (and (not (eof-object? record)) - (< read size) - (loop (read-ustar-record port) read)))))) - (chmod file-name (ustar-header-mode header)) - (let ((mtime (ustar-header-mtime header))) - (utime file-name mtime mtime)))) + (file-name (ustar-header-file-name header)) + (dir (dirname file-name)) + (thunk (lambda _ + (let loop ((record (read-ustar-record port)) (wrote 0)) + (let* ((read (+ wrote 512)) + (block (if (< read size) record + (sub-bytevector record 0 (- size wrote))))) + (when extract? + (display (bv->ustar-0string block "block"))) + (and (not (eof-object? record)) + (< read size) + (loop (read-ustar-record port) read))))))) + (when extract? + (mkdir-p dir)) + (if extract? (with-output-to-file file-name thunk) + (thunk)) + (when extract? + (chmod file-name (ustar-header-mode header)) + (let ((mtime (ustar-header-mtime header))) + (utime file-name mtime mtime))))) -(define (extract-ustar-archive file-name files) +(define (display-rwx perm) + (display (if (zero? (logand perm 4)) "-" "r")) + (display (if (zero? (logand perm 2)) "-" "w")) + (display (if (zero? (logand perm 1)) "-" "x"))) + +(define* (display-header header #:key verbose?) + (when verbose? + (let ((mode (ustar-header-mode header)) + (uid (ustar-header-uid header)) + (gid (ustar-header-gid header)) + (size (ustar-header-size header)) + (date (strftime "%c" (localtime (ustar-header-mtime header))))) + (display "-") + (display-rwx (ash mode -6)) + (display-rwx (ash (logand mode #o70) -3)) + (display-rwx (logand mode #o7)) + (display " ") + (format #t "~8s" uid) + (display " ") + (format #t "~8s" gid) + (format #t "~8d" size) + (display " ") + (display date) + (display " "))) + (display (ustar-header-file-name header)) + (newline)) + +(define* (create-ustar-archive file-name files #:key group mtime numeric-owner? owner verbosity) (catch #t - (lambda () - (call-with-port* (open-file file-name "rb") - (lambda (in) - (let loop ((header (read-ustar-header in))) - (when (and header - (not (eof-object? header))) - (extract-ustar-file in header) - (loop (read-ustar-header in))))))) - (lambda (key subr message args . rest) - (format (current-error-port) "ERROR: ~a\n" - (apply format #f message args)) - (exit 1)))) - -(define* (create-ustar-archive file-name files #:key group mtime numeric-owner? owner) - (catch 'fubar (lambda () (call-with-port* (open-file file-name "wb") (lambda (out) (for-each (cut write-ustar-file out <> - #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner) + #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity) files) (write-ustar-footer out)))) (lambda (key subr message args . rest) @@ -475,6 +495,26 @@ (apply format #f message args)) (exit 1)))) +(define* (extract-ustar-archive file-name files #:key (extract? #t) verbosity) + (catch #t + (lambda () + (call-with-port* (open-file file-name "rb") + (lambda (in) + (let loop ((header (read-ustar-header in))) + (when (and header + (not (eof-object? header))) + (unless (zero? verbosity) + (display-header header #:verbose? (not (zero? verbosity)))) + (extract-ustar-file in header #:extract? extract?) + (loop (read-ustar-header in))))))) + (lambda (key subr message args . rest) + (format (current-error-port) "ERROR: ~a\n" + (apply format #f message args)) + (exit 1)))) + +(define* (list-ustar-archive file-name files #:key verbosity) + (extract-ustar-archive file-name files #:extract? #:verbosity verbosity)) + ;;; Local Variables: ;;; mode: scheme ;;; eval: (put 'call-with-port* 'scheme-indent-function 1) From 4e671558e565a1bd2e938cfde2768b689d5280a4 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 27 Oct 2018 09:53:12 +0200 Subject: [PATCH 168/312] tar: Nicer verbose listing of files. * gash/guix-build-utils.scm (display-file): New function. * gash/ustar.scm (display-header): Use it. (ustar-header->stat): New function. --- gash/guix-build-utils.scm | 44 ++++++++++++++++++++++++++++++ gash/ustar.scm | 57 +++++++++++++++++++++------------------ 2 files changed, 75 insertions(+), 26 deletions(-) diff --git a/gash/guix-build-utils.scm b/gash/guix-build-utils.scm index 340bec6..23a0bcb 100644 --- a/gash/guix-build-utils.scm +++ b/gash/guix-build-utils.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2015, 2018 Mark H Weaver +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Gash. ;;; @@ -23,6 +24,7 @@ (define-module (gash guix-build-utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) #:use-module (ice-9 ftw) #:use-module (ice-9 match) @@ -33,6 +35,7 @@ #:use-module (rnrs io ports) #:export ( delete-file-recursively + display-file dump-port file-name-predicate find-files @@ -238,3 +241,44 @@ transferred and the continuation of the transfer as a thunk." (loop tail path) (apply throw args)))))) (() #t)))) + +(define* (display-file file-name #:optional st) + (define (display-rwx perm sticky) + (display (if (zero? (logand perm 4)) "-" "r")) + (display (if (zero? (logand perm 2)) "-" "w")) + (display (let ((x (logand perm 1))) + (if (zero? sticky) (if (zero? x) "-" "x") + (if (= sticky 1) (if (zero? x) "T" "t") + (if (zero? x) "S" "s")))))) + (define (display-bcdfsl type) + (display + (case type + ((block-special) "b") + ((char-special) "c") + ((directory) "d") + ((fifo) "p") + ((regular) "-") + ((socket) "s") + ((symlink) "l") + (else "?")))) + (let* ((mode (stat:mode st)) + (uid (stat:uid st)) + (gid (stat:gid st)) + (size (stat:size st)) + (date (strftime "%c" (localtime (stat:mtime st)))) + (sticky (ash mode -9))) + (display-bcdfsl (stat:type st)) + (display-rwx (ash mode -6) (logand sticky 4)) + (display-rwx (ash (logand mode #o70) -3) (logand sticky 2)) + (display-rwx (logand mode #o7) (logand sticky 1)) + (display " ") + (let ((ent (catch #t (compose passwd:name (cut getpwuid uid)) (const uid)))) + (format #t "~8a" ent)) + (display " ") + (let ((ent (catch #t (compose group:name (cut getgrgid gid)) (const gid)))) + (format #t "~8a" ent)) + (format #t "~8d" size) + (display " ") + (display date) + (display " ")) + (display file-name)) diff --git a/gash/ustar.scm b/gash/ustar.scm index 6271e74..6e110bc 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -226,6 +226,16 @@ (dev-minor ustar-header-dev-minor) (prefix ustar-header-prefix )) +(define (ustar-header-type header) + (let ((file-types #(regular - symlink char-special block-special directory fifo)) + (type (string->number (ustar-header-type-flag header)))) + (when (or (not type) + (< type 0) + (>= type (vector-length file-types))) + (fmt-error "~a: unsupported file type ~a" + (ustar-header-file-name header) type)) + (vector-ref file-types (string->number (ustar-header-type-flag header))))) + (define ustar-header-field-size-alist '((name . 100) (mode . 8) @@ -404,6 +414,10 @@ (st (lstat file-name)) (type (stat:type st)) (size (stat:size st))) + (unless (zero? verbosity) + (if (> verbosity 1) (display-file file-name st) + (display file-name)) + (newline)) (write-ustar-header port file-name st #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner) (case type ((regular) @@ -452,32 +466,23 @@ (let ((mtime (ustar-header-mtime header))) (utime file-name mtime mtime))))) -(define (display-rwx perm) - (display (if (zero? (logand perm 4)) "-" "r")) - (display (if (zero? (logand perm 2)) "-" "w")) - (display (if (zero? (logand perm 1)) "-" "x"))) +(define (ustar-header->stat header) + (let* ((stat-size 17) + (si (list->vector (iota stat-size))) + (st (make-vector stat-size 0))) + (vector-set! st (stat:mode si) (ustar-header-mode header)) + (vector-set! st (stat:uid si) (ustar-header-uid header)) + (vector-set! st (stat:gid si) (ustar-header-gid header)) + (vector-set! st (stat:size si) (ustar-header-size header)) + (vector-set! st (stat:mtime si) (ustar-header-mtime header)) + (vector-set! st (stat:type si) (ustar-header-type header)) + st)) (define* (display-header header #:key verbose?) - (when verbose? - (let ((mode (ustar-header-mode header)) - (uid (ustar-header-uid header)) - (gid (ustar-header-gid header)) - (size (ustar-header-size header)) - (date (strftime "%c" (localtime (ustar-header-mtime header))))) - (display "-") - (display-rwx (ash mode -6)) - (display-rwx (ash (logand mode #o70) -3)) - (display-rwx (logand mode #o7)) - (display " ") - (format #t "~8s" uid) - (display " ") - (format #t "~8s" gid) - (format #t "~8d" size) - (display " ") - (display date) - (display " "))) - (display (ustar-header-file-name header)) - (newline)) + (let ((file-name (ustar-header-file-name header))) + (if verbose? (display-file (ustar-header-file-name header) (ustar-header->stat header)) + (display file-name)) + (newline))) (define* (create-ustar-archive file-name files #:key group mtime numeric-owner? owner verbosity) (catch #t @@ -504,7 +509,7 @@ (when (and header (not (eof-object? header))) (unless (zero? verbosity) - (display-header header #:verbose? (not (zero? verbosity)))) + (display-header header #:verbose? (> verbosity 1))) (extract-ustar-file in header #:extract? extract?) (loop (read-ustar-header in))))))) (lambda (key subr message args . rest) @@ -513,7 +518,7 @@ (exit 1)))) (define* (list-ustar-archive file-name files #:key verbosity) - (extract-ustar-archive file-name files #:extract? #:verbosity verbosity)) + (extract-ustar-archive file-name files #:extract? #f #:verbosity verbosity)) ;;; Local Variables: ;;; mode: scheme From 8aad6451527c3efc362857b5f4d90e4cf4e23a08 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 27 Oct 2018 10:44:20 +0200 Subject: [PATCH 169/312] ls: Support -l. * gash/bournish-commands.scm (ls-command-implementation): Support -l. --- gash/bournish-commands.scm | 10 +++++++--- gash/guix-build-utils.scm | 3 ++- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 1d13941..57a8d52 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -116,11 +116,13 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." (let* ((option-spec '((all (single-char #\a)) (help) + (long (single-char #\l)) (one-file-per-line (single-char #\1)) (version))) (options (getopt-long (cons "ls" args) option-spec)) (all? (option-ref options 'all #f)) (help? (option-ref options 'help #f)) + (long? (option-ref options 'long #f)) (one-file-per-line? (option-ref options 'one-file-per-line #f)) (version? (option-ref options 'version #f)) (files (option-ref options '() '()))) @@ -128,9 +130,10 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." Options: -a, --all do not ignore entries starting with . - -1 list one file per line --help display this help and exit + -l, --long use a long listing format --version display version information and exit + -1 list one file per line ")) (version? (format #t "ls (GASH) ~a\n" %version)) (else @@ -161,8 +164,9 @@ Options: files))) (files (if all? files (filter (negate (cut string-prefix? "." <>)) files)))) - (if one-file-per-line? (for-each stdout files) - (display-tabulated files)))))))) + (cond (long? (for-each (lambda (f) (display-file f) (newline)) files)) + (one-file-per-line? (for-each stdout files)) + (else (display-tabulated files))))))))) (define ls-command (wrap-command ls-command-implementation "ls")) diff --git a/gash/guix-build-utils.scm b/gash/guix-build-utils.scm index 23a0bcb..33ce0f6 100644 --- a/gash/guix-build-utils.scm +++ b/gash/guix-build-utils.scm @@ -261,7 +261,8 @@ transferred and the continuation of the transfer as a thunk." ((socket) "s") ((symlink) "l") (else "?")))) - (let* ((mode (stat:mode st)) + (let* ((st (or st (lstat file-name))) + (mode (stat:mode st)) (uid (stat:uid st)) (gid (stat:gid st)) (size (stat:size st)) From 975f53d98edb733db9b14746ea973f93a41d9764 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 27 Oct 2018 11:19:21 +0200 Subject: [PATCH 170/312] bournish: Add compress, from Guile100 challenge by Daniel Hartwig. WIP --- .gitignore | 1 + build-aux/build-guile.sh | 3 + configure | 1 + gash/bournish-commands.scm | 54 ++++++++++--- gash/compress.scm | 158 +++++++++++++++++++++++++++++++++++++ gash/lzw.scm | 151 +++++++++++++++++++++++++++++++++++ gash/ustar.scm | 8 ++ 7 files changed, 367 insertions(+), 9 deletions(-) create mode 100644 gash/compress.scm create mode 100644 gash/lzw.scm diff --git a/.gitignore b/.gitignore index 8f42809..ebb4f43 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ *.go *~ /bin/cat +/bin/compress /bin/cp /bin/find /bin/gash diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 9dbe8ec..8890283 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -42,12 +42,14 @@ SCM_FILES=" gash/bournish-commands.scm gash/guix-build-utils.scm gash/builtins.scm +gash/compress.scm gash/config.scm gash/environment.scm gash/geesh.scm gash/gash.scm gash/io.scm gash/job.scm +gash/lzw.scm gash/peg.scm gash/pipe.scm gash/script.scm @@ -68,6 +70,7 @@ done SCRIPTS=" bin/cat +bin/compress bin/cp bin/find bin/gash diff --git a/configure b/configure index a8dd2b6..c4e6d63 100755 --- a/configure +++ b/configure @@ -36,6 +36,7 @@ sed \ chmod +x bin/gash BUILTINS=" cat +compress cp find grep diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 57a8d52..6807a86 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -31,6 +31,7 @@ #:use-module (srfi srfi-26) #:use-module (gash guix-build-utils) + #:use-module (gash compress) #:use-module (gash config) #:use-module (gash io) #:use-module (gash ustar) @@ -439,15 +440,50 @@ Usage: tar [OPTION]... [FILE]... (list? (list-ustar-archive file files #:verbosity (1+ verbosity))))))) +(define (compress-command . args) + (lambda _ + (let* ((option-spec + '((bits (single-char #\b) (value #t)) + (decompress (single-char #\d)) + (help (single-char #\h)) + (stdout (single-char #\c)) + (verbose (single-char #\v)) + (version (single-char #\V)))) + (args (cons "compress" args)) + (options (getopt-long args option-spec)) + (bits (string->number (option-ref options 'bits "16"))) + (decompress? (option-ref options 'decompress #f)) + (stdout? (option-ref options 'stdout #f)) + (files (option-ref options '() '())) + (help? (option-ref options 'help #f)) + (usage? (and (not help?) (or (and (null? files) (not stdout?))))) + (verbose? (option-ref options 'verbose #f)) + (version? (option-ref options 'version #f))) + (cond ((or help? usage?) (format (if usage? (current-error-port) #t) + "\ +Usage: compress [OPTION]... [FILE]... + -b, --bits=BITS use a maximum of BITS bits per code [16] + -c, --stdout write on standard output, keep original files unchanged + -d, --decompress decompress + -h, --help display this help + -v, --verbose show compression ratio + -V, --version display version +") + (exit (if usage? 2 0))) + (version? (format #t "compress (GASH) ~a\n" %version) (exit 0)) + (decompress? (uncompress-file (car files) verbose?)) + (else (compress-file (car files) bits verbose?)))))) + (define %bournish-commands `( - ("cat" . ,cat-command) - ("cp" . ,cp-command) - ("find" . ,find-command) - ("grep" . ,grep-command) - ("ls" . ,ls-command) - ("reboot" . ,reboot-command) - ("tar" . ,tar-command) - ("wc" . ,wc-command) - ("which" . ,which-command) + ("cat" . ,cat-command) + ("compress" . ,compress-command) + ("cp" . ,cp-command) + ("find" . ,find-command) + ("grep" . ,grep-command) + ("ls" . ,ls-command) + ("reboot" . ,reboot-command) + ("tar" . ,tar-command) + ("wc" . ,wc-command) + ("which" . ,which-command) )) diff --git a/gash/compress.scm b/gash/compress.scm new file mode 100644 index 0000000..63cc931 --- /dev/null +++ b/gash/compress.scm @@ -0,0 +1,158 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2013 Daniel Hartwig +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial lzw.scm was taken from the Guile100 challenge +;;; https://github.com/spk121/guile100 from a contribution by Daniel +;;; Hartwig. + +;;; Code: + +(define-module (gash compress) + #:use-module (gash lzw) + #:use-module (ice-9 control) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-37) + #:export (compress-file + compress-port + uncompress-file + uncompress-port)) + +(define *program-name* "compress (GASH)") + +(define (_ msg . rest) + (cons msg rest)) + +(define (error* status msg . args) + (force-output) + (let ((port (current-error-port))) + (when *program-name* + (display *program-name* port) + (display ": " port)) + (apply format port msg args) + (newline port) + (unless (zero? status) + ;; This call to 'abort' causes 'main' to immediately return the + ;; specified status value. Similar to 'exit' but more + ;; controlled, for example, when using the REPL to debug, + ;; 'abort' will not cause the entire process to terminate. + ;; + ;; This is also handy to attempt processing every file, even + ;; after an error has occured. To do this, establish another + ;; prompt at an interesting place inside 'main'. + (abort (lambda (k) + status))))) + +(define (make-file-error-handler filename) + (lambda args + (error* 1 (_ "~a: ~a") + filename + (strerror (system-error-errno args))))) + +(define (system-error-handler key subr msg args rest) + (apply error* 1 msg args)) + +(define (compression-ratio nbytes-in nbytes-out) + (exact->inexact (/ (- nbytes-in nbytes-out) nbytes-in))) + +(define (write-lzw-header port bits) + (put-bytevector port (u8-list->bytevector (list #x1F #x9D bits)))) + +(define (compress-port in out bits verbose?) + #; + (begin + (write-lzw-header out bits) + (%lzw-compress (cute get-u8 in) + (cute put-u16 out <>) + eof-object? + (expt 2 bits))) + (let* ((in-bv (get-bytevector-all in)) + (out-bv (lzw-compress in-bv #:table-size (expt 2 bits)))) + (write-lzw-header out bits) + (put-bytevector out out-bv))) + +(define (compress-file infile bits verbose?) + (catch 'system-error + (lambda () + (let ((outfile (string-append infile ".Z"))) + (when (string-suffix? ".Z" infile) + (error* 1 (_ "~a: already has .Z suffix") infile)) + (when (file-exists? outfile) + (error* 1 (_ "~a: already exists") outfile)) + (let ((in (open-file infile "rb")) + (out (open-file outfile "wb"))) + ;; TODO: Keep original files ownership, modes, and access + ;; and modification times. + (compress-port in out bits verbose?) + (when verbose? + (format #; (current-error-port) + (current-output-port) + (_ "~a: compression: ~1,2h%\n") ; '~h' is localized '~f'. + infile + (* 100 (compression-ratio (port-position in) + (port-position out))))) + (for-each close-port (list in out)) + (delete-file infile)))) + system-error-handler)) + +(define (read-lzw-header port) + (match (bytevector->u8-list (get-bytevector-n port 3)) + ((#x1F #x9D bits) + (and (<= 9 bits 16) + (values bits))) + (x #f))) + +(define (uncompress-port in out verbose?) + (let ((bits (read-lzw-header in))) + (unless bits + (error* 1 (_ "incorrect header"))) + #; + (%lzw-uncompress (cute get-u16 in) + (cute put-u8 out <>) + eof-object? + (expt 2 bits)) + (let* ((in-bv (get-bytevector-all in)) + (out-bv (lzw-uncompress in-bv #:table-size (expt 2 bits)))) + (put-bytevector out out-bv)))) + +(define (uncompress-file infile verbose?) + (catch 'system-error + (lambda () + (let ((outfile (string-drop-right infile 2))) + (when (not (string-suffix? ".Z" infile)) + (error* 1 (_ "~a: does not have .Z suffix") infile)) + (when (file-exists? outfile) + (error* 1 (_ "~a: already exists") outfile)) + (let ((in (open-file infile "rb")) + (out (open-file outfile "wb"))) + (uncompress-port in out verbose?) + (when verbose? + (format #; (current-error-port) + (current-output-port) + (_ "~a: compression: ~1,2h%\n") ; '~h is localized '~f'. + infile + (* 100 (compression-ratio (port-position out) + (port-position in))))) + (for-each close-port (list in out)) + (delete-file infile)))) + system-error-handler)) diff --git a/gash/lzw.scm b/gash/lzw.scm new file mode 100644 index 0000000..fcf7a2c --- /dev/null +++ b/gash/lzw.scm @@ -0,0 +1,151 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2013 Daniel Hartwig +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial lzw.scm was taken from the Guile100 challenge +;;; https://github.com/spk121/guile100 from a contribution by Daniel +;;; Hartwig. + +;;; Code: + +(define-module (gash lzw) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (lzw-compress + lzw-uncompress + %lzw-compress + %lzw-uncompress)) + +;; This procedure adapted from an example in the Guile Reference +;; Manual. +(define (make-serial-number-generator start end) + (let ((current-serial-number (- start 1))) + (lambda () + (and (< current-serial-number end) + (set! current-serial-number (+ current-serial-number 1)) + current-serial-number)))) + +(define (put-u16 port k) + ;; Little endian. + (put-u8 port (logand k #xFF)) + (put-u8 port (logand (ash k -8) #xFF))) + +(define (get-u16 port) + ;; Little endian. Order of evaluation is important, use 'let*'. + (let* ((a (get-u8 port)) + (b (get-u8 port))) + (if (any eof-object? (list a b)) + (eof-object) + (logior a (ash b 8))))) + +(define (%lzw-compress in out done? table-size) + (let ((codes (make-hash-table table-size)) + (next-code (make-serial-number-generator 0 table-size)) + (universe (iota 256)) + (eof-code #f)) + ;; Populate the initial dictionary with all one-element strings + ;; from the universe. + (for-each (lambda (obj) + (hash-set! codes (list obj) (next-code))) + universe) + (set! eof-code (next-code)) + (let loop ((cs '())) + (let ((c (in))) + (cond ((done? c) + (unless (null? cs) + (out (hash-ref codes cs))) + (out eof-code) + (values codes)) + ((hash-ref codes (cons c cs)) + (loop (cons c cs))) + (else + (and=> (next-code) + (cut hash-set! codes (cons c cs) <>)) + (out (hash-ref codes cs)) + (loop (cons c '())))))))) + +(define (ensure-bv-input-port bv-or-port) + (cond ((port? bv-or-port) + bv-or-port) + ((bytevector? bv-or-port) + (open-bytevector-input-port bv-or-port)) + (else + (scm-error 'wrong-type-arg "ensure-bv-input-port" + "Wrong type argument in position ~a: ~s" + (list 1 bv-or-port) (list bv-or-port))))) + +(define (for-each-right proc lst) + (let loop ((lst lst)) + (unless (null? lst) + (loop (cdr lst)) + (proc (car lst))))) + +(define (%lzw-uncompress in out done? table-size) + (let ((strings (make-hash-table table-size)) + (next-code (make-serial-number-generator 0 table-size)) + (universe (iota 256)) + (eof-code #f)) + (for-each (lambda (obj) + (hash-set! strings (next-code) (list obj))) + universe) + (set! eof-code (next-code)) + (let loop ((previous-string '())) + (let ((code (in))) + (unless (or (done? code) + (= code eof-code)) + (unless (hash-ref strings code) + (hash-set! strings + code + (cons (last previous-string) previous-string))) + (for-each-right out + (hash-ref strings code)) + (let ((cs (hash-ref strings code))) + (and=> (and (not (null? previous-string)) + (next-code)) + (cut hash-set! strings <> (cons (last cs) + previous-string))) + (loop cs))))))) + +(define* (lzw-compress bv #:key (table-size 65536) dictionary) + (call-with-values + (lambda () + (open-bytevector-output-port)) + (lambda (output-port get-result) + (let ((dict (%lzw-compress (cute get-u8 (ensure-bv-input-port bv)) + (cute put-u16 output-port <>) + eof-object? + table-size))) + (if dictionary + (values (get-result) dict) + (get-result)))))) + +(define* (lzw-uncompress bv #:key (table-size 65536) dictionary) + (call-with-values + (lambda () + (open-bytevector-output-port)) + (lambda (output-port get-result) + (let ((dict (%lzw-uncompress (cute get-u16 (open-bytevector-input-port bv)) + (cute put-u8 output-port <>) + eof-object? + table-size))) + (if dictionary + (values (get-result) dict) + (get-result)))))) diff --git a/gash/ustar.scm b/gash/ustar.scm index 6e110bc..215fe54 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -17,6 +17,14 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with Gash. If not, see . +;;; Commentary: + +;;; The initial ustar.scm was taken from the Guile100 challenge +;;; https://github.com/spk121/guile100 from a contribution by Mark H +;;; Weaver. + +;;; Code: + (define-module (gash ustar) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) From 8b56dcc2ab11454bf51ee15d4ddcdad2d4da54bf Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 27 Oct 2018 18:57:48 +0200 Subject: [PATCH 171/312] compress: play nice with GNU tar. * gash/bournish-commands.scm (compress-command): Compress/decompress from stdin if not tty. --- gash/bournish-commands.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 6807a86..5758c96 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -456,7 +456,7 @@ Usage: tar [OPTION]... [FILE]... (stdout? (option-ref options 'stdout #f)) (files (option-ref options '() '())) (help? (option-ref options 'help #f)) - (usage? (and (not help?) (or (and (null? files) (not stdout?))))) + (usage? (and (not help?) (or (and (null? files) (isatty? (current-input-port)))))) (verbose? (option-ref options 'verbose #f)) (version? (option-ref options 'version #f))) (cond ((or help? usage?) (format (if usage? (current-error-port) #t) @@ -471,8 +471,10 @@ Usage: compress [OPTION]... [FILE]... ") (exit (if usage? 2 0))) (version? (format #t "compress (GASH) ~a\n" %version) (exit 0)) - (decompress? (uncompress-file (car files) verbose?)) - (else (compress-file (car files) bits verbose?)))))) + (decompress? (if (pair? files) (uncompress-file (car files) verbose?) + (uncompress-port (current-input-port) (current-output-port) verbose?))) + (else (if (pair? files) (compress-file (car files) bits verbose?) + (compress-port (current-input-port) (current-output-port) bits verbose?))))))) (define %bournish-commands `( From e3e20738c22fb6d75c89401b189839f927eede46 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 27 Oct 2018 19:37:40 +0200 Subject: [PATCH 172/312] tar: Handle stdin, stdout. * gash/ustar.scm (list-ustar-port, extract-ustar-port, write-ustar-port): New function. * gash/bournish-commands.scm (tar-command): Use them. --- gash/bournish-commands.scm | 36 ++++++++++++++------- gash/ustar.scm | 64 ++++++++++++++++++++++++++------------ 2 files changed, 68 insertions(+), 32 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 5758c96..9b8d70d 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -393,7 +393,7 @@ Options: (create? (option-ref options 'create #f)) (list? (option-ref options 'list #f)) (extract? (option-ref options 'extract #f)) - (file (option-ref options 'file "/dev/stdout")) + (file (option-ref options 'file "-")) (files (option-ref options '() '())) (help? (option-ref options 'help #f)) (usage? (and (not help?) (not (or (and create? (pair? files)) @@ -426,19 +426,31 @@ Usage: tar [OPTION]... [FILE]... (mtime (and=> (option-ref options 'mtime #f) string->number)) (numeric-owner? (option-ref options 'numeric-owner? #f)) (owner (and=> (option-ref options 'owner #f) string->number))) - (apply create-ustar-archive - `(,file - ,files - ,@(if group `(#:group ,group) '()) - ,@(if mtime `(#:mtime ,mtime) '()) - ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) - ,@(if owner `(#:owner ,owner) '()) - ,@(if owner `(#:owner ,owner) '()) - #:verbosity ,verbosity)))) + (if (equal? file "-") + (apply write-ustar-port (current-output-port) + `(,file + ,files + ,@(if group `(#:group ,group) '()) + ,@(if mtime `(#:mtime ,mtime) '()) + ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) + ,@(if owner `(#:owner ,owner) '()) + ,@(if owner `(#:owner ,owner) '()) + #:verbosity ,verbosity)) + (apply write-ustar-archive + `(,file + ,files + ,@(if group `(#:group ,group) '()) + ,@(if mtime `(#:mtime ,mtime) '()) + ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) + ,@(if owner `(#:owner ,owner) '()) + ,@(if owner `(#:owner ,owner) '()) + #:verbosity ,verbosity))))) (extract? - (extract-ustar-archive file files #:verbosity verbosity)) + (if (equal? file "-") (read-ustar-port (current-input-port) files #:verbosity verbosity) + (read-ustar-archive file files #:verbosity verbosity))) (list? - (list-ustar-archive file files #:verbosity (1+ verbosity))))))) + (if (equal? file "-") (list-ustar-port (current-input-port) files #:verbosity (1+ verbosity)) + (list-ustar-archive file files #:verbosity (1+ verbosity)))))))) (define (compress-command . args) (lambda _ diff --git a/gash/ustar.scm b/gash/ustar.scm index 215fe54..a1d1d65 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -34,9 +34,12 @@ #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (gash guix-build-utils) - #:export (create-ustar-archive - extract-ustar-archive - list-ustar-archive)) + #:export (read-ustar-archive + read-ustar-port + write-ustar-archive + write-ustar-port + list-ustar-archive + list-ustar-port)) (define (fmt-error fmt . args) (error (apply format #f fmt args))) @@ -492,34 +495,52 @@ (display file-name)) (newline))) -(define* (create-ustar-archive file-name files #:key group mtime numeric-owner? owner verbosity) +(define* (write-ustar-port out files #:key group mtime numeric-owner? owner verbosity) (catch #t (lambda () - (call-with-port* (open-file file-name "wb") - (lambda (out) - (for-each - (cut write-ustar-file out <> - #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity) - files) - (write-ustar-footer out)))) + (for-each + (cut write-ustar-file out <> + #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity) + files) + (write-ustar-footer out)) (lambda (key subr message args . rest) (false-if-exception (delete-file file-name)) (format (current-error-port) "ERROR: ~a\n" (apply format #f message args)) (exit 1)))) -(define* (extract-ustar-archive file-name files #:key (extract? #t) verbosity) +(define* (write-ustar-archive file-name files #:key group mtime numeric-owner? owner verbosity) (catch #t + (lambda () + (call-with-port* (open-file file-name "wb") + (cut write-ustar-port <> files + #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity))) + (lambda (key subr message args . rest) + (false-if-exception (delete-file file-name)) + (format (current-error-port) "ERROR: ~a\n" + (apply format #f message args)) + (exit 1)))) + +(define* (extract-ustar-port in files #:key (extract? #t) verbosity) + (catch #t + (lambda () + (let loop ((header (read-ustar-header in))) + (when (and header + (not (eof-object? header))) + (unless (zero? verbosity) + (display-header header #:verbose? (> verbosity 1))) + (extract-ustar-file in header #:extract? extract?) + (loop (read-ustar-header in))))) + (lambda (key subr message args . rest) + (format (current-error-port) "ERROR: ~a\n" + (apply format #f message args)) + (exit 1)))) + +(define* (extract-ustar-archive file-name files #:key (extract? #t) verbosity) + (catch 'foo (lambda () (call-with-port* (open-file file-name "rb") - (lambda (in) - (let loop ((header (read-ustar-header in))) - (when (and header - (not (eof-object? header))) - (unless (zero? verbosity) - (display-header header #:verbose? (> verbosity 1))) - (extract-ustar-file in header #:extract? extract?) - (loop (read-ustar-header in))))))) + (cut extract-ustar-port <> files #:extract? extract? verbosity))) (lambda (key subr message args . rest) (format (current-error-port) "ERROR: ~a\n" (apply format #f message args)) @@ -528,6 +549,9 @@ (define* (list-ustar-archive file-name files #:key verbosity) (extract-ustar-archive file-name files #:extract? #f #:verbosity verbosity)) +(define* (list-ustar-port in file-name files #:key verbosity) + (extract-ustar-port file-name files #:extract? #f #:verbosity verbosity)) + ;;; Local Variables: ;;; mode: scheme ;;; eval: (put 'call-with-port* 'scheme-indent-function 1) From a10247aab17f63a0c9613a493b0bfd09d703144d Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 27 Oct 2018 21:29:46 +0200 Subject: [PATCH 173/312] tar: Support compression. * gash/guix-utils.scm: New file, partial import from Guix. Throughout: Add `compress.' * build-aux/build-guile.sh: Compile it. * gash/config.scm.in: Support it by defining compressors. * configure: Substitute them. * gash/bournish-commands.scm (tar-command): Use it to have tar support compression and decompression. --- build-aux/build-guile.sh | 1 + configure | 10 ++ gash/bournish-commands.scm | 58 +++++++--- gash/config.scm.in | 18 ++- gash/guix-build-utils.scm | 5 + gash/guix-utils.scm | 217 +++++++++++++++++++++++++++++++++++++ gash/ustar.scm | 29 ++--- 7 files changed, 310 insertions(+), 28 deletions(-) create mode 100644 gash/guix-utils.scm diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 8890283..b11e9f6 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -41,6 +41,7 @@ set -e SCM_FILES=" gash/bournish-commands.scm gash/guix-build-utils.scm +gash/guix-utils.scm gash/builtins.scm gash/compress.scm gash/config.scm diff --git a/configure b/configure index c4e6d63..105840c 100755 --- a/configure +++ b/configure @@ -70,7 +70,17 @@ SHELL=$BASH VERSION=$VERSION EOF +BZIP2=$(command -v bzip2) +COMPRESS=$(command -v compress) +[ -z "$COMPRESS" ] && COMPRESS=$PWD/bin/compress +GZIP=$(command -v gzip) +XZ=$(command -v xz) + sed \ + -e "s,@BZIP2@,$BZIP2,"\ + -e "s,@COMPRESS@,$COMPRESS,"\ + -e "s,@GZIP@,$GZIP,"\ + -e "s,@XZ@,$XZ,"\ -e "s,@VERSION@,$VERSION,"\ gash/config.scm.in > gash/config.scm diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 9b8d70d..2c27b5b 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -19,6 +19,12 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with Gash. If not, see . +;;; Commentary: + +;;; The initial bournish.scm was taken from Guix. + +;;; Code: + (define-module (gash bournish-commands) #:use-module (ice-9 ftw) #:use-module (ice-9 getopt-long) @@ -31,6 +37,7 @@ #:use-module (srfi srfi-26) #:use-module (gash guix-build-utils) + #:use-module (gash guix-utils) #:use-module (gash compress) #:use-module (gash config) #:use-module (gash io) @@ -377,6 +384,10 @@ Options: (lambda _ (let* ((option-spec '((create (single-char #\c)) + (compress (single-char #\Z)) + (gzip (single-char #\z)) + (bzip2 (single-char #\j)) + (xz (single-char #\J)) (group (value #t)) (extract (single-char #\x)) (file (single-char #\f) (value #t)) @@ -390,6 +401,15 @@ Options: (version (single-char #\V)))) (args (cons "tar" args)) (options (getopt-long args option-spec)) + (compress? (option-ref options 'compress #f)) + (bzip2? (option-ref options 'bzip2 #f)) + (gzip? (option-ref options 'gzip #f)) + (xz? (option-ref options 'xz #f)) + (compression (cond (bzip2? 'bzip2) + (compress? 'compress) + (gzip? 'gzip) + (xz? 'xz) + (else #f))) (create? (option-ref options 'create #f)) (list? (option-ref options 'list #f)) (extract? (option-ref options 'extract #f)) @@ -416,6 +436,8 @@ Usage: tar [OPTION]... [FILE]... -V, --version display version -v, --verbose verbosely list files processed -x, --extract extract files from an archive + -z, --gzip filter the archive through gzip + -Z, --compress filter the archive through compress ") (exit (if usage? 2 0))) (version? (format #t "tar (GASH) ~a\n" %version) (exit 0)) @@ -426,16 +448,18 @@ Usage: tar [OPTION]... [FILE]... (mtime (and=> (option-ref options 'mtime #f) string->number)) (numeric-owner? (option-ref options 'numeric-owner? #f)) (owner (and=> (option-ref options 'owner #f) string->number))) - (if (equal? file "-") - (apply write-ustar-port (current-output-port) - `(,file - ,files - ,@(if group `(#:group ,group) '()) - ,@(if mtime `(#:mtime ,mtime) '()) - ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) - ,@(if owner `(#:owner ,owner) '()) - ,@(if owner `(#:owner ,owner) '()) - #:verbosity ,verbosity)) + (if (or compression (equal? file "-")) + (let ((port (if (equal? file "-") (current-output-port) + (open-file file "wb")))) + (call-with-compressed-output-port compression port + (cut apply write-ustar-port <> + `(,files + ,@(if group `(#:group ,group) '()) + ,@(if mtime `(#:mtime ,mtime) '()) + ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) + ,@(if owner `(#:owner ,owner) '()) + ,@(if owner `(#:owner ,owner) '()) + #:verbosity ,verbosity)))) (apply write-ustar-archive `(,file ,files @@ -446,11 +470,19 @@ Usage: tar [OPTION]... [FILE]... ,@(if owner `(#:owner ,owner) '()) #:verbosity ,verbosity))))) (extract? - (if (equal? file "-") (read-ustar-port (current-input-port) files #:verbosity verbosity) + (if (or compression (equal? file "-")) + (let ((port (if (equal? file "-") (current-input-port) + (open-file file "rb")))) + (call-with-decompressed-port compression port + (cut read-ustar-port <> files #:verbosity verbosity))) (read-ustar-archive file files #:verbosity verbosity))) (list? - (if (equal? file "-") (list-ustar-port (current-input-port) files #:verbosity (1+ verbosity)) - (list-ustar-archive file files #:verbosity (1+ verbosity)))))))) + (if (or compression (equal? file "-")) + (let ((port (if (equal? file "-") (current-input-port) + (open-file file "rb")))) + (call-with-decompressed-port compression port + (cut list-ustar-port <> files #:verbosity (1+ verbosity)))) + (list-ustar-archive file files #:verbosity (1+ verbosity)))))))) (define (compress-command . args) (lambda _ diff --git a/gash/config.scm.in b/gash/config.scm.in index 078e827..439839c 100644 --- a/gash/config.scm.in +++ b/gash/config.scm.in @@ -17,7 +17,11 @@ ;;; along with Gash. If not, see . (define-module (gash config) - #:export (%version)) + #:export (%bzip2 + %xz + %compress + %gzip + %version)) ;;; Commentary: ;;; @@ -28,3 +32,15 @@ (define %version "@VERSION@") + +(define %bzip2 + "@BZIP2@") + +(define %compress + "@COMPRESS@") + +(define %gzip + "@GZIP@") + +(define %xz + "@XZ@") diff --git a/gash/guix-build-utils.scm b/gash/guix-build-utils.scm index 33ce0f6..5deb307 100644 --- a/gash/guix-build-utils.scm +++ b/gash/guix-build-utils.scm @@ -20,6 +20,11 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with Gash. If not, see . +;;; Commentary: + +;;; The initial guix-build-utils.scm was taken from Guix. + +;;; Code: (define-module (gash guix-build-utils) #:use-module (srfi srfi-1) diff --git a/gash/guix-utils.scm b/gash/guix-utils.scm new file mode 100644 index 0000000..e0c6906 --- /dev/null +++ b/gash/guix-utils.scm @@ -0,0 +1,217 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015 Mark H Weaver +;;; Copyright © 2014 Eric Bavier +;;; Copyright © 2014 Ian Denhardt +;;; Copyright © 2016 Mathieu Lirzin +;;; Copyright © 2015 David Thompson +;;; Copyright © 2017 Efraim Flashner +;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2018 Marius Bakke +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial guix-utils.scm was taken from Guix. + +;;; Code: + + +(define-module (gash guix-utils) + #:use-module (srfi srfi-1) + ;; #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + ;; #:use-module (srfi srfi-26) + ;; #:use-module (srfi srfi-35) + ;; #:use-module (srfi srfi-39) + ;; #:use-module (ice-9 binary-ports) + ;; #:autoload (rnrs io ports) (make-custom-binary-input-port) + ;; #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) + ;; #:use-module (guix memoization) + ;; #:use-module ((guix build utils) #:select (dump-port mkdir-p)) + ;; #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) + ;; #:use-module (ice-9 format) + #:autoload (ice-9 popen) (open-pipe*) + ;; #:autoload (ice-9 rdelim) (read-line) + ;; #:use-module (ice-9 regex) + #:use-module (ice-9 match) + ;; #:use-module (ice-9 format) + ;; #:use-module ((ice-9 iconv) #:prefix iconv:) + ;; #:use-module (system foreign) + #:use-module (gash config) + #:export (filtered-port + compressed-port + decompressed-port + call-with-decompressed-port + compressed-output-port + call-with-compressed-output-port)) + + +;;; +;;; Filtering & pipes. +;;; + +(define (filtered-port command input) + "Return an input port where data drained from INPUT is filtered through +COMMAND (a list). In addition, return a list of PIDs that the caller must +wait. When INPUT is a file port, it must be unbuffered; otherwise, any +buffered data is lost." + (let loop ((input input) + (pids '())) + (if (file-port? input) + (match (pipe) + ((in . out) + (match (primitive-fork) + (0 + (dynamic-wind + (const #f) + (lambda () + (close-port in) + (close-port (current-input-port)) + (dup2 (fileno input) 0) + (close-port (current-output-port)) + (dup2 (fileno out) 1) + (catch 'system-error + (lambda () + (apply execl (car command) command)) + (lambda args + (format (current-error-port) + "filtered-port: failed to execute '~{~a ~}': ~a~%" + command (strerror (system-error-errno args)))))) + (lambda () + (primitive-_exit 1)))) + (child + (close-port out) + (values in (cons child pids)))))) + + ;; INPUT is not a file port, so fork just for the sake of tunneling it + ;; through a file port. + (match (pipe) + ((in . out) + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (close-port in) + (dump-port input out)) + (lambda () + (close-port input) + (false-if-exception (close out)) + (primitive-_exit 0)))) + (child + (close-port input) + (close-port out) + (loop in (cons child pids))))))))) + +(define (decompressed-port compression input) + "Return an input port where INPUT is decompressed according to COMPRESSION, +a symbol such as 'xz." + (match compression + ((or #f 'none) (values input '())) + ('bzip2 (filtered-port `(,%bzip2 "-dc") input)) + ('compress (filtered-port `(,%compress "-dc") input)) + ('xz (filtered-port `(,%xz "-dc" "-T0") input)) + ('gzip (filtered-port `(,%gzip "-dc") input)) + (else (error "unsupported compression scheme" compression)))) + +(define (compressed-port compression input) + "Return an input port where INPUT is decompressed according to COMPRESSION, +a symbol such as 'xz." + (match compression + ((or #f 'none) (values input '())) + ('bzip2 (filtered-port `(,%bzip2 "-c") input)) + ('compress (filtered-port `(,%compress "-c") input)) + ('xz (filtered-port `(,%xz "-c" "-T0") input)) + ('gzip (filtered-port `(,%gzip "-c") input)) + (else (error "unsupported compression scheme" compression)))) + +(define (call-with-decompressed-port compression port proc) + "Call PROC with a wrapper around PORT, a file port, that decompresses data +read from PORT according to COMPRESSION, a symbol such as 'xz." + (let-values (((decompressed pids) + (decompressed-port compression port))) + (dynamic-wind + (const #f) + (lambda () + (proc decompressed)) + (lambda () + (close-port decompressed) + (unless (every (compose zero? cdr waitpid) pids) + (error "decompressed-port failure" pids)))))) + +(define (filtered-output-port command output) + "Return an output port. Data written to that port is filtered through +COMMAND and written to OUTPUT, an output file port. In addition, return a +list of PIDs to wait for. OUTPUT must be unbuffered; otherwise, any buffered +data is lost." + (match (pipe) + ((in . out) + (match (primitive-fork) + (0 + (dynamic-wind + (const #f) + (lambda () + (close-port out) + (close-port (current-input-port)) + (dup2 (fileno in) 0) + (close-port (current-output-port)) + (dup2 (fileno output) 1) + (catch 'system-error + (lambda () + (apply execl (car command) command)) + (lambda args + (format (current-error-port) + "filtered-output-port: failed to execute '~{~a ~}': ~a~%" + command (strerror (system-error-errno args)))))) + (lambda () + (primitive-_exit 1)))) + (child + (close-port in) + (values out (list child))))))) + +(define* (compressed-output-port compression output + #:key (options '())) + "Return an output port whose input is compressed according to COMPRESSION, +a symbol such as 'xz, and then written to OUTPUT. In addition return a list +of PIDs to wait for. OPTIONS is a list of strings passed to the compression +program--e.g., '(\"--fast\")." + (match compression + ((or #f 'none) (values output '())) + ('bzip2 (filtered-output-port `(,%bzip2 "-c" ,@options) output)) + ('compress (filtered-output-port `(,%compress "-c" ,@options) output)) + ('xz (filtered-output-port `(,%xz "-c" "-T0" ,@options) output)) + ('gzip (filtered-output-port `(,%gzip "-c" ,@options) output)) + (else (error "unsupported compression scheme" compression)))) + +(define* (call-with-compressed-output-port compression port proc + #:key (options '())) + "Call PROC with a wrapper around PORT, a file port, that compresses data +that goes to PORT according to COMPRESSION, a symbol such as 'xz. OPTIONS is +a list of command-line arguments passed to the compression program." + (let-values (((compressed pids) + (compressed-output-port compression port + #:options options))) + (dynamic-wind + (const #f) + (lambda () + (proc compressed)) + (lambda () + (close-port compressed) + (unless (every (compose zero? cdr waitpid) pids) + (error "compressed-output-port failure" pids)))))) diff --git a/gash/ustar.scm b/gash/ustar.scm index a1d1d65..3dea668 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -445,7 +445,8 @@ (write-ustar-record port buf 0 obtained) (loop (- left obtained))))))))) ((directory) - (for-each (lambda (file-name) (write-ustar-file port file-name)) + (for-each (lambda (file-name) (write-ustar-file port file-name + #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity)) (files-in-directory file-name)))))) (define (ustar-header-file-name header) @@ -454,7 +455,7 @@ (if (string-null? prefix) name (string-append prefix "/" name)))) -(define* (extract-ustar-file port header #:key (extract? #t)) +(define* (read-ustar-file port header #:key (extract? #t)) (let* ((size (ustar-header-size header)) (file-name (ustar-header-file-name header)) (dir (dirname file-name)) @@ -497,7 +498,7 @@ (define* (write-ustar-port out files #:key group mtime numeric-owner? owner verbosity) (catch #t - (lambda () + (lambda _ (for-each (cut write-ustar-file out <> #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity) @@ -511,7 +512,7 @@ (define* (write-ustar-archive file-name files #:key group mtime numeric-owner? owner verbosity) (catch #t - (lambda () + (lambda _ (call-with-port* (open-file file-name "wb") (cut write-ustar-port <> files #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity))) @@ -521,36 +522,36 @@ (apply format #f message args)) (exit 1)))) -(define* (extract-ustar-port in files #:key (extract? #t) verbosity) +(define* (read-ustar-port in files #:key (extract? #t) verbosity) (catch #t - (lambda () + (lambda _ (let loop ((header (read-ustar-header in))) (when (and header (not (eof-object? header))) (unless (zero? verbosity) (display-header header #:verbose? (> verbosity 1))) - (extract-ustar-file in header #:extract? extract?) + (read-ustar-file in header #:extract? extract?) (loop (read-ustar-header in))))) (lambda (key subr message args . rest) (format (current-error-port) "ERROR: ~a\n" (apply format #f message args)) (exit 1)))) -(define* (extract-ustar-archive file-name files #:key (extract? #t) verbosity) - (catch 'foo - (lambda () +(define* (read-ustar-archive file-name files #:key (extract? #t) verbosity) + (catch #t + (lambda _ (call-with-port* (open-file file-name "rb") - (cut extract-ustar-port <> files #:extract? extract? verbosity))) + (cut read-ustar-port <> files #:extract? extract? #:verbosity verbosity))) (lambda (key subr message args . rest) (format (current-error-port) "ERROR: ~a\n" (apply format #f message args)) (exit 1)))) (define* (list-ustar-archive file-name files #:key verbosity) - (extract-ustar-archive file-name files #:extract? #f #:verbosity verbosity)) + (read-ustar-archive file-name files #:extract? #f #:verbosity verbosity)) -(define* (list-ustar-port in file-name files #:key verbosity) - (extract-ustar-port file-name files #:extract? #f #:verbosity verbosity)) +(define* (list-ustar-port in files #:key verbosity) + (read-ustar-port in files #:extract? #f #:verbosity verbosity)) ;;; Local Variables: ;;; mode: scheme From d2133b85022c65c0b5c8b29adffbaebf8c696cde Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 27 Oct 2018 22:14:44 +0200 Subject: [PATCH 174/312] tar: Support old cvf/xvf and auto-compress. * gash/bournish-commands.scm (tar-command): Support old cvf/xvf and auto compress (use archive suffix to determine the compression. --- gash/bournish-commands.scm | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 2c27b5b..8f4b402 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -401,6 +401,20 @@ Options: (version (single-char #\V)))) (args (cons "tar" args)) (options (getopt-long args option-spec)) + (options (if (or (option-ref options 'create #f) + (option-ref options 'extract #f) + (option-ref options 'list #f) + (null? (cdr args)) + (string-prefix? "-" (cadr args))) options + (let ((args (cons* (car args) + (string-append "-" (cadr args)) + (cddr args)))) + (getopt-long args option-spec)))) + (create? (option-ref options 'create #f)) + (list? (option-ref options 'list #f)) + (extract? (option-ref options 'extract #f)) + (file (option-ref options 'file "-")) + (files (option-ref options '() '())) (compress? (option-ref options 'compress #f)) (bzip2? (option-ref options 'bzip2 #f)) (gzip? (option-ref options 'gzip #f)) @@ -409,12 +423,12 @@ Options: (compress? 'compress) (gzip? 'gzip) (xz? 'xz) - (else #f))) - (create? (option-ref options 'create #f)) - (list? (option-ref options 'list #f)) - (extract? (option-ref options 'extract #f)) - (file (option-ref options 'file "-")) - (files (option-ref options '() '())) + (else (and (or extract? list? ) + (cond ((string-suffix? ".Z" file) 'compress) + ((string-suffix? ".bz2" file) 'bzip2) + ((string-suffix? ".gz" file) 'gzip) + ((string-suffix? ".xz" file) 'xz) + (else #f)))))) (help? (option-ref options 'help #f)) (usage? (and (not help?) (not (or (and create? (pair? files)) extract? list?)))) From f7c1dd6e725e8b4d7efff37826c93a78f5494acd Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 29 Oct 2018 21:13:41 +0100 Subject: [PATCH 175/312] Make readline optional. * gash/readline.scm: New file. * build-aux/build-guile.sh: Compile it. * gash/gash.scm: Use it as fallback. --- build-aux/build-guile.sh | 1 + gash/gash.scm | 6 +++++- gash/readline.scm | 41 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 47 insertions(+), 1 deletion(-) create mode 100644 gash/readline.scm diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index b11e9f6..e3b6327 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -53,6 +53,7 @@ gash/job.scm gash/lzw.scm gash/peg.scm gash/pipe.scm +gash/readline.scm gash/script.scm gash/ustar.scm gash/util.scm diff --git a/gash/gash.scm b/gash/gash.scm index 346e3ac..eea1972 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -9,7 +9,6 @@ #:use-module (ice-9 local-eval) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) - #:use-module (ice-9 readline) #:use-module (ice-9 pretty-print) #:use-module (ice-9 receive) #:use-module (ice-9 regex) @@ -30,6 +29,11 @@ parse parse-string)) +(catch #t + (lambda _ (use-modules (ice-9 readline))) + (lambda (key . args) + (use-modules (gash readline)))) + (define %debug-level 0) ; 1 informational, 2 verbose, 3 peg tracing (define %prefer-builtins? #f) ; use builtin, even if COMMAND is available in PATH? (define %geesh-parser? #f) ; use Geesh parser [EXPERIMENTAL] diff --git a/gash/readline.scm b/gash/readline.scm new file mode 100644 index 0000000..3b4d960 --- /dev/null +++ b/gash/readline.scm @@ -0,0 +1,41 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; This is a fallback module for the bootstrap guile where (ice-9 +;;; readline) is not available. + +;;; Code: + +(define-module (gash readline) + #:use-module (ice-9 rdelim) + #:export (add-history + clear-history + read-history + readline + with-readline-completion-function + write-history)) + +(define (add-history x) #t) +(define (clear-history) #t) +(define (read-history x) #t) +(define (readline prompt) (display prompt) (read-line)) +(define (with-readline-completion-function completion thunk) (thunk)) +(define (write-history x) #t) + From 1fd796bad7eda9649b895cc092d93b263a154879 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 27 Oct 2018 23:34:39 +0200 Subject: [PATCH 176/312] guix: build fixes. * bin/builtin.in: Remove gratuitous quotes. * configure (BUILTINS): Add bash and sh scripts. * gash/builtins.scm (command-command): Add missing format parameter. (type-command): Likewise. * gash/guix-build-utils.scm: Use (ice-9 format). * gash/guix-utils.scm: Likewise. * gash/ustar.scm (write-ustar-port): Remove catch. (read-ustar-port): Likewise. --- bin/builtin.in | 3 +- bin/gash.in | 2 +- configure | 2 ++ gash/builtins.scm | 4 +-- gash/config.scm.in | 6 +++- gash/guix-build-utils.scm | 1 + gash/guix-utils.scm | 18 ++---------- gash/ustar.scm | 36 ++++++++---------------- stack.scm | 59 --------------------------------------- 9 files changed, 26 insertions(+), 105 deletions(-) delete mode 100644 stack.scm diff --git a/bin/builtin.in b/bin/builtin.in index 0ef6eba..72fc775 100644 --- a/bin/builtin.in +++ b/bin/builtin.in @@ -1,7 +1,8 @@ #! @GUILE@ \ ---no-auto-compile -e main -L "@GUILE_SITE_DIR@" -C "@GUILE_SITE_CCACHE_DIR@" -L . -C . -s +--no-auto-compile -e main -L @GUILE_SITE_DIR@ -C @GUILE_SITE_CCACHE_DIR@ -L . -C . -s !# ;;; Gash --- Guile As SHell +;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Gash. diff --git a/bin/gash.in b/bin/gash.in index 84bbe23..f42446a 100644 --- a/bin/gash.in +++ b/bin/gash.in @@ -1,5 +1,5 @@ #! @GUILE@ \ ---no-auto-compile -e main -L "@GUILE_SITE_DIR@" -C "@GUILE_SITE_CCACHE_DIR@" -L . -C . -s +--no-auto-compile -e main -L @GUILE_SITE_DIR@ -C @GUILE_SITE_CCACHE_DIR@ -L . -C . -s !# ;;; Gash --- Guile As SHell ;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom diff --git a/configure b/configure index 105840c..43f97cd 100755 --- a/configure +++ b/configure @@ -35,6 +35,7 @@ sed \ bin/gash.in > bin/gash chmod +x bin/gash BUILTINS=" +bash cat compress cp @@ -42,6 +43,7 @@ find grep ls reboot +sh tar wc which diff --git a/gash/builtins.scm b/gash/builtins.scm index 44c740e..5aa7ac0 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -167,7 +167,7 @@ Options: (cond (builtin (format #t "~a is a shell builtin\n" command) 0) (else (let ((program (PATH-search-path command))) - (if (string? program) (begin (format #t "~a hashed (~a)\n" command ) 0) + (if (string? program) (begin (format #t "~a hashed (~a)\n" command program) 0) 1)))))) ((option-ref options 'show #f) (let* ((command (car files)) @@ -217,7 +217,7 @@ Options: (cond (builtin (format #t "~a is a shell builtin\n" command) 0) (else (let ((program (PATH-search-path command))) - (if (string? program) (begin (format #t "~a hashed (~a)\n" command ) 0) + (if (string? program) (begin (format #t "~a hashed (~a)\n" command program) 0) 1)))))))))))) (define test-command diff --git a/gash/config.scm.in b/gash/config.scm.in index 439839c..264e4b0 100644 --- a/gash/config.scm.in +++ b/gash/config.scm.in @@ -37,7 +37,11 @@ "@BZIP2@") (define %compress - "@COMPRESS@") + (let ((compress "@COMPRESS@") + (reloc (string-append (dirname (car (command-line))) "/compress"))) + (cond ((getenv "COMPRESS")) + ((file-exists? compress) compress) + ((file-exists? reloc) reloc)))) (define %gzip "@GZIP@") diff --git a/gash/guix-build-utils.scm b/gash/guix-build-utils.scm index 5deb307..6ec2903 100644 --- a/gash/guix-build-utils.scm +++ b/gash/guix-build-utils.scm @@ -32,6 +32,7 @@ #:use-module (srfi srfi-26) #:use-module (ice-9 ftw) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) diff --git a/gash/guix-utils.scm b/gash/guix-utils.scm index e0c6906..4b3c90a 100644 --- a/gash/guix-utils.scm +++ b/gash/guix-utils.scm @@ -34,25 +34,11 @@ (define-module (gash guix-utils) #:use-module (srfi srfi-1) - ;; #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) - ;; #:use-module (srfi srfi-26) - ;; #:use-module (srfi srfi-35) - ;; #:use-module (srfi srfi-39) - ;; #:use-module (ice-9 binary-ports) - ;; #:autoload (rnrs io ports) (make-custom-binary-input-port) - ;; #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) - ;; #:use-module (guix memoization) - ;; #:use-module ((guix build utils) #:select (dump-port mkdir-p)) - ;; #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) - ;; #:use-module (ice-9 format) + #:use-module (ice-9 format) #:autoload (ice-9 popen) (open-pipe*) - ;; #:autoload (ice-9 rdelim) (read-line) - ;; #:use-module (ice-9 regex) + #:use-module ((gash guix-build-utils) #:select (dump-port)) #:use-module (ice-9 match) - ;; #:use-module (ice-9 format) - ;; #:use-module ((ice-9 iconv) #:prefix iconv:) - ;; #:use-module (system foreign) #:use-module (gash config) #:export (filtered-port compressed-port diff --git a/gash/ustar.scm b/gash/ustar.scm index 3dea668..db0701e 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -497,18 +497,10 @@ (newline))) (define* (write-ustar-port out files #:key group mtime numeric-owner? owner verbosity) - (catch #t - (lambda _ - (for-each - (cut write-ustar-file out <> - #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity) - files) - (write-ustar-footer out)) - (lambda (key subr message args . rest) - (false-if-exception (delete-file file-name)) - (format (current-error-port) "ERROR: ~a\n" - (apply format #f message args)) - (exit 1)))) + (for-each + (cut write-ustar-file out <> + #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity) + files)) (define* (write-ustar-archive file-name files #:key group mtime numeric-owner? owner verbosity) (catch #t @@ -523,19 +515,13 @@ (exit 1)))) (define* (read-ustar-port in files #:key (extract? #t) verbosity) - (catch #t - (lambda _ - (let loop ((header (read-ustar-header in))) - (when (and header - (not (eof-object? header))) - (unless (zero? verbosity) - (display-header header #:verbose? (> verbosity 1))) - (read-ustar-file in header #:extract? extract?) - (loop (read-ustar-header in))))) - (lambda (key subr message args . rest) - (format (current-error-port) "ERROR: ~a\n" - (apply format #f message args)) - (exit 1)))) + (let loop ((header (read-ustar-header in))) + (when (and header + (not (eof-object? header))) + (unless (zero? verbosity) + (display-header header #:verbose? (> verbosity 1))) + (read-ustar-file in header #:extract? extract?) + (loop (read-ustar-header in))))) (define* (read-ustar-archive file-name files #:key (extract? #t) verbosity) (catch #t diff --git a/stack.scm b/stack.scm deleted file mode 100644 index 065a7fd..0000000 --- a/stack.scm +++ /dev/null @@ -1,59 +0,0 @@ -(use-modules (ice-9 match)) - -(use-modules (system vm frame) - (system vm trace)) - -(define (to-string o) - (match o - ((? string?) o) - ((? symbol?) (symbol->string o)) - ((? number?) (number->string o)) - ((? list?) (string-join (map to-string o) " ")) - ((? pair?) (string-join (list (to-string (car o)) (to-string (cdr o))) " ")) - (_ "???"))) - -(define (location frame) - (let ((source (frame-source frame))) - (if source - (let* ((args (frame-arguments frame)) - (args (if (null? args) "" (string-append " args: " (to-string args)))) - (foo (format (current-output-port) "~a\n" (frame-procedure frame)))) - (string-append (cadr source) ":" - (number->string (caddr source)) ":" args)) - source))) - -(define (stack-trace) - (let ((skip-stack-capture-crap 0) - (stack (make-stack #t))) - (filter identity (let loop ((frame (stack-ref stack skip-stack-capture-crap))) - (if (not (frame? frame)) '() - (cons (location frame) (loop (frame-previous frame)))))))) - -(define (main) - (catch #t - (lambda () - (with-throw-handler - #t - foo - (lambda (key . args) - (stdout "error: " args) - (throw 'exception (stack-trace))))) - (lambda (key . args) - (map stdout (car args))))) - -(define (foo) - (bar '(a b)) - (format (current-output-port) "foo\n")) - -(define (stdout . o) - (map (lambda (o) (display o (current-output-port))) o) - (newline) - o) - -(define (bar arg) - (match arg - ('a 'a) - ((? pair?) (map bar arg))) - (format (current-output-port) "bar\n")) - -(main) From b463aa32bcaa979c4e104d101cf8b3d9f9fcca72 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 29 Oct 2018 07:40:57 +0100 Subject: [PATCH 177/312] tar: Handle extracting of directories. * gash/ustar.scm (read-ustar-file): Do not dump content of directory. Size is 0; do not start by reading 512 bytes. --- gash/ustar.scm | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/gash/ustar.scm b/gash/ustar.scm index db0701e..03d7524 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -460,18 +460,25 @@ (file-name (ustar-header-file-name header)) (dir (dirname file-name)) (thunk (lambda _ - (let loop ((record (read-ustar-record port)) (wrote 0)) - (let* ((read (+ wrote 512)) - (block (if (< read size) record - (sub-bytevector record 0 (- size wrote))))) - (when extract? - (display (bv->ustar-0string block "block"))) - (and (not (eof-object? record)) - (< read size) - (loop (read-ustar-record port) read))))))) + (let loop ((read 0)) + (and (< read size) + (let ((record (read-ustar-record port))) + (and record + (let* ((read (+ read 512)) + (block (if (< read size) record + (sub-bytevector record 0 (- size -512 read))))) + (when extract? + (display (bv->ustar-0string block "block"))) + (loop read))))))))) (when extract? (mkdir-p dir)) - (if extract? (with-output-to-file file-name thunk) + (if extract? + (case (ustar-header-type header) + ((regular) + (if (file-exists? file-name) (delete-file file-name)) + (with-output-to-file file-name thunk)) + ((directory) (mkdir-p file-name)) + ((symlink) (throw 'todo "symlink"))) (thunk)) (when extract? (chmod file-name (ustar-header-mode header)) From 5296fdbf2ce8d7328c9a2deb1b6582f4bfb9ca87 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 29 Oct 2018 19:02:17 +0100 Subject: [PATCH 178/312] tar: Use latin-1 (binary) codec instead of utf8. --- gash/ustar.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/gash/ustar.scm b/gash/ustar.scm index 03d7524..73ab410 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -86,7 +86,7 @@ name (string-filter (negate valid-ustar-char?) str) str)) - (bytevector-pad (string->utf8 str) n)) + (bytevector-pad (string->bytevector str (make-transcoder (latin-1-codec))) n)) (define (ustar-0string n str name) (bytevector-pad (ustar-string (- n 1) str name) @@ -99,9 +99,10 @@ (fmt-error "~a is not a non-negative exact integer: ~a" name num)) (unless (< num (expt 8 (- n 1))) (fmt-error "~a is too large (max ~a): ~a" name (expt 8 (- n 1)) num)) - (bytevector-pad (string->utf8 (string-pad (number->string num 8) + (bytevector-pad (string->bytevector (string-pad (number->string num 8) (- n 1) - #\0)) + #\0) + (make-transcoder (latin-1-codec))) n)) (define (checksum-bv bv) From 3e8b021f0b2742a824f59c8aa5df6c60f783f101 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 29 Oct 2018 20:47:32 +0100 Subject: [PATCH 179/312] bournish: Do not display help if --version is requested. * gash/bournish-commands.scm (ls-command-implementation): Do not display help if --version is requested. (find-command-implementation): Likewise. (grep-command): Likewise. (tar-command): Likewise. (compress-command): Likewise. --- gash/bournish-commands.scm | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 8f4b402..3e3c3ea 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -134,7 +134,8 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." (one-file-per-line? (option-ref options 'one-file-per-line #f)) (version? (option-ref options 'version #f)) (files (option-ref options '() '()))) - (cond (help? (display "Usage: ls [OPTION]... [FILE]... + (cond (version? (format #t "ls (GASH) ~a\n" %version)) + (help? (display "Usage: ls [OPTION]... [FILE]... Options: -a, --all do not ignore entries starting with . @@ -143,7 +144,6 @@ Options: --version display version information and exit -1 list one file per line ")) - (version? (format #t "ls (GASH) ~a\n" %version)) (else (let* ((files (if (null? files) (scandir ".") (append-map (lambda (file) @@ -299,13 +299,13 @@ Options: (error "find failed")) ;; TODO: find [OPTION]... [FILE]... [EXPRESSION]... ;; and options: esp: -x, -L - (cond (help? (display "Usage: find [OPTION]... [FILE] + (cond (version? (format #t "find (GASH) ~a\n" %version)) + (help? (display "Usage: find [OPTION]... [FILE] Options: --help display this help and exit --version display version information and exit ")) - (version? (format #t "find (GASH) ~a\n" %version)) (else (let* ((files (find-files file #:directories? #t #:fail-on-error? #t))) (for-each stdout files))))))) @@ -327,7 +327,8 @@ Options: (help? (option-ref options 'help #f)) (version? (option-ref options 'version #f)) (files (option-ref options '() '()))) - (cond (help? (display "Usage: grep [OPTION]... PATTERN [FILE]... + (cond (version? (format #t "grep (GASH) ~a\n" %version)) + (help? (display "Usage: grep [OPTION]... PATTERN [FILE]... Options: --help display this help and exit @@ -339,7 +340,6 @@ Options: -o, --only-matching show only the part of a line matching PATTERN -V, --version display version information and exit ")) - (version? (format #t "grep (GASH) ~a\n" %version)) ((null? files) #t) (else (let* ((pattern (car files)) @@ -434,7 +434,8 @@ Options: extract? list?)))) (verbosity (length (multi-opt options 'verbose))) (version? (option-ref options 'version #f))) - (cond ((or help? usage?) (format (if usage? (current-error-port) #t) + (cond (version? (format #t "tar (GASH) ~a\n" %version) (exit 0)) + ((or help? usage?) (format (if usage? (current-error-port) #t) "\ Usage: tar [OPTION]... [FILE]... -c, --create create a new archive @@ -454,7 +455,6 @@ Usage: tar [OPTION]... [FILE]... -Z, --compress filter the archive through compress ") (exit (if usage? 2 0))) - (version? (format #t "tar (GASH) ~a\n" %version) (exit 0)) (create? (let ((files (if (not (option-ref options 'sort #f)) files (sort files string<))) @@ -517,7 +517,8 @@ Usage: tar [OPTION]... [FILE]... (usage? (and (not help?) (or (and (null? files) (isatty? (current-input-port)))))) (verbose? (option-ref options 'verbose #f)) (version? (option-ref options 'version #f))) - (cond ((or help? usage?) (format (if usage? (current-error-port) #t) + (cond (version? (format #t "compress (GASH) ~a\n" %version) (exit 0)) + ((or help? usage?) (format (if usage? (current-error-port) #t) "\ Usage: compress [OPTION]... [FILE]... -b, --bits=BITS use a maximum of BITS bits per code [16] @@ -528,7 +529,6 @@ Usage: compress [OPTION]... [FILE]... -V, --version display version ") (exit (if usage? 2 0))) - (version? (format #t "compress (GASH) ~a\n" %version) (exit 0)) (decompress? (if (pair? files) (uncompress-file (car files) verbose?) (uncompress-port (current-input-port) (current-output-port) verbose?))) (else (if (pair? files) (compress-file (car files) bits verbose?) From 1e5389f01d0787622f2d869f54cc579f0e1e333c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 30 Oct 2018 07:09:29 +0100 Subject: [PATCH 180/312] builtins: Oops, have \NAME run builtin. * gash/script.scm (command): Oops have \NAME run builtin. (pipeline): Filter-out # (xtrace residue). --- gash/script.scm | 33 +++++++++++++++++---------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/gash/script.scm b/gash/script.scm index 129e907..289343f 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -76,8 +76,8 @@ (escape-builtin? (and (string? program) (string-prefix? "\\" program))) (program (if escape-builtin? (string-drop program 1) program)) (command (cons program (cdr command)))) - (or (builtin command #:prefer-builtin? (and %prefer-builtins? - (not escape-builtin?))) + (or (builtin command #:prefer-builtin? (or %prefer-builtins? + escape-builtin?)) (cut apply (compose status:exit-val system*) command)))) (else (lambda () #t)))) (exec (append-map glob args))) @@ -206,20 +206,21 @@ (shell-opt? "errexit")) (exit status)) status)) - (when (> %debug-level 1) - (format (current-error-port) "pijp: commands=~s\n" commands)) - ;; FIXME: after running a builtin, we still end up here with the builtin's result - ;; that should probably not happen, however, cater for it here for now - (match commands - (((and (? boolean?) boolean)) - (handle boolean)) - (((and (? number?) number)) - (handle number)) - (((? unspecified?)) - (handle #t)) - (((? unspecified?) t ... #t) - #t) - (_ (handle (apply pipeline+ #t commands))))) + (let ((commands (filter (lambda (x) (not (eq? x *unspecified*))) commands))) + (when (> %debug-level 1) + (format (current-error-port) "pijp: commands=~s\n" commands)) + ;; FIXME: after running a builtin, we still end up here with the builtin's result + ;; that should probably not happen, however, cater for it here for now + (match commands + (((and (? boolean?) boolean)) + (handle boolean)) + (((and (? number?) number)) + (handle number)) + (((? unspecified?)) + (handle #t)) + (((? unspecified?) t ... #t) + #t) + (_ (handle (apply pipeline+ #t commands)))))) (define* (builtin ast #:key prefer-builtin?) ;; FIXME: distinguish between POSIX compliant builtins and From b433052b4aa50ad9e05d083f4f777be867c7529e Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 30 Oct 2018 19:45:01 +0100 Subject: [PATCH 181/312] builtins: Split out into gash/commands/. * gash/commands/cat.scm: New file, expand from bournish-commands.scm. * gash/commands/compress.scm: Likewise. * gash/commands/cp.scm: Likewise. * gash/commands/find.scm: Likewise. * gash/commands/grep.scm: Likewise. * gash/commands/ls.scm: Likewise. * gash/commands/reboot.scm: Likewise. * gash/commands/tar.scm: Likewise. * gash/commands/wc.scm: Likewise. * gash/commands/which.scm: Likewise. * build-aux/pre-inst-env.in: New file. * configure: Expand it. * gash/bournish-commands.scm: Remove. * gash/shell-utils.scm: Rename from guix-build-utils.scm. --- .gitignore | 3 + AUTHORS | 9 +- bin/builtin.in | 4 +- bin/gash.in | 2 +- build-aux/build-guile.sh | 13 +- build-aux/pre-inst-env.in | 45 ++ configure | 113 ++-- gash/bournish-commands.scm | 530 ++---------------- gash/builtins.scm | 2 +- gash/commands/cat.scm | 41 ++ gash/commands/compress.scm | 68 +++ gash/commands/cp.scm | 36 ++ gash/commands/find.scm | 65 +++ gash/commands/grep.scm | 109 ++++ gash/commands/ls.scm | 106 ++++ gash/commands/reboot.scm | 44 ++ gash/commands/tar.scm | 152 +++++ gash/commands/wc.scm | 81 +++ gash/commands/which.scm | 38 ++ gash/config.scm.in | 7 + gash/gash.scm | 4 +- gash/guix-utils.scm | 3 +- gash/io.scm | 2 - gash/script.scm | 3 +- .../{guix-build-utils.scm => shell-utils.scm} | 68 ++- gash/ustar.scm | 2 +- gash/util.scm | 8 - makefile | 30 +- 28 files changed, 1010 insertions(+), 578 deletions(-) create mode 100644 build-aux/pre-inst-env.in create mode 100644 gash/commands/cat.scm create mode 100644 gash/commands/compress.scm create mode 100644 gash/commands/cp.scm create mode 100644 gash/commands/find.scm create mode 100644 gash/commands/grep.scm create mode 100644 gash/commands/ls.scm create mode 100644 gash/commands/reboot.scm create mode 100644 gash/commands/tar.scm create mode 100644 gash/commands/wc.scm create mode 100644 gash/commands/which.scm rename gash/{guix-build-utils.scm => shell-utils.scm} (82%) diff --git a/.gitignore b/.gitignore index ebb4f43..d5690d4 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,6 @@ *.go *~ +/bin/bash /bin/cat /bin/compress /bin/cp @@ -8,9 +9,11 @@ /bin/grep /bin/ls /bin/reboot +/bin/sh /bin/tar /bin/wc /bin/which /.config.make /doc/version.texi /gash/config.scm +/pre-inst-env diff --git a/AUTHORS b/AUTHORS index 4d3661a..bcce19a 100644 --- a/AUTHORS +++ b/AUTHORS @@ -3,8 +3,13 @@ Main author All files except the imported files listed below Adapted from GNU Guix -gash/bournish-commands.scm -gash/guix-build-utils.scm +gash/commands/*.scm +gash/shell-utils.scm +gash/guix-utils.scm Adapted from Mes build-aux/build-guile.sh + +Adapted from Guile100 Challenge +gash/compress.scm +gash/ustar.scm diff --git a/bin/builtin.in b/bin/builtin.in index 72fc775..d0eff5f 100644 --- a/bin/builtin.in +++ b/bin/builtin.in @@ -1,5 +1,5 @@ #! @GUILE@ \ ---no-auto-compile -e main -L @GUILE_SITE_DIR@ -C @GUILE_SITE_CCACHE_DIR@ -L . -C . -s +--no-auto-compile -e main -L @guile_site_dir@ -C @guile_site_ccache_dir@ -L . -C . -s !# ;;; Gash --- Guile As SHell ;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom @@ -21,4 +21,4 @@ ;;; along with Gash. If not, see . (define (main args) - ((@ (gash gash) main) (cons* (car (command-line)) "--" "@builtin@" (cdr (command-line))))) + (apply (@@ (gash commands @builtin@) main) args)) diff --git a/bin/gash.in b/bin/gash.in index f42446a..c7587d1 100644 --- a/bin/gash.in +++ b/bin/gash.in @@ -1,5 +1,5 @@ #! @GUILE@ \ ---no-auto-compile -e main -L @GUILE_SITE_DIR@ -C @GUILE_SITE_CCACHE_DIR@ -L . -C . -s +--no-auto-compile -e main -L @guile_site_dir@ -C @guile_site_ccache_dir@ -L . -C . -s !# ;;; Gash --- Guile As SHell ;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index e3b6327..5b55be7 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -40,7 +40,6 @@ set -e SCM_FILES=" gash/bournish-commands.scm -gash/guix-build-utils.scm gash/guix-utils.scm gash/builtins.scm gash/compress.scm @@ -55,8 +54,20 @@ gash/peg.scm gash/pipe.scm gash/readline.scm gash/script.scm +gash/shell-utils.scm gash/ustar.scm gash/util.scm + +gash/commands/cat.scm +gash/commands/compress.scm +gash/commands/cp.scm +gash/commands/find.scm +gash/commands/grep.scm +gash/commands/ls.scm +gash/commands/reboot.scm +gash/commands/tar.scm +gash/commands/wc.scm +gash/commands/which.scm " export srcdir=. diff --git a/build-aux/pre-inst-env.in b/build-aux/pre-inst-env.in new file mode 100644 index 0000000..0f45566 --- /dev/null +++ b/build-aux/pre-inst-env.in @@ -0,0 +1,45 @@ +#! @BASH@ + +# Gash -- Guile As SHell +# Copyright © 2018 Jan (janneke) Nieuwenhuizen +# +# This file is part of Gash. +# +# Gash is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or (at +# your option) any later version. +# +# Gash is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License +# along with Gash. If not, see . + +srcdir="@srcdir@" +abs_top_srcdir="@abs_top_srcdir@" +abs_top_builddir="@abs_top_builddir@" +prefix=${prefix-@prefix@} + +MES_PREFIX=${MES_PREFIX-${srcdest}mes} +export MES_PREFIX + +GUILE_LOAD_COMPILED_PATH="$abs_top_builddir/bin:$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH" +GUILE_LOAD_PATH="$abs_top_srcdir${GUILE_LOAD_PATH:+:}$GUILE_LOAD_PATH" +if [ -n "$srcdest" ]; then + GUILE_LOAD_PATH="${srcdest}module:${srcdest}mes:$GUILE_LOAD_PATH" +fi +export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH + +PATH="$abs_top_builddir/bin:$PATH" +export PATH + +COMMANDS="$abs_top_builddir/gash/commands" +export COMMANDS + +LANG= +LC_ALL= + +exec "$@" diff --git a/configure b/configure index 43f97cd..b4d2d68 100755 --- a/configure +++ b/configure @@ -14,9 +14,9 @@ fi BASH=$(command -v bash) GUILE=$(command -v guile) GUILE_TOOLS=$(command -v guile-tools) -GUILE_SITE_DIR=$PREFIX/share/guile/site/$GUILE_EFFECTIVE_VERSION -GUILE_SITE_CCACHE_DIR=$PREFIX/lib/guile/$GUILE_EFFECTIVE_VERSION/site-ccache -GUILE_EFFECTIVE_VERSION=$(guile -c '(display (effective-version))') +guile_site_dir=$PREFIX/share/guile/site/$guile_effective_version +guile_site_ccache_dir=$PREFIX/lib/guile/$guile_effective_version/site-ccache +guile_effective_version=$(guile -c '(display (effective-version))') MAKEINFO=$(command -v makeinfo) GEESH_PREFIX=${GEESH_PREFIX-$HOME/src/geesh} if [ -d $GEESH_PREFIX ]; then @@ -28,45 +28,25 @@ if [ -d $GEESH_PREFIX ]; then fi fi -sed \ - -e s,@GUILE@,$GUILE,\ - -e s,@GUILE_SITE_DIR@,$GUILE_SITE_DIR,\ - -e s,@GUILE_SITE_CCACHE_DIR@,$GUILE_SITE_CCACHE_DIR,\ - bin/gash.in > bin/gash -chmod +x bin/gash -BUILTINS=" -bash -cat -compress -cp -find -grep -ls -reboot -sh -tar -wc -which -" -for builtin in $BUILTINS; do - sed \ - -e s,@GUILE@,$GUILE,\ - -e s,@GUILE_SITE_DIR@,$GUILE_SITE_DIR,\ - -e s,@GUILE_SITE_CCACHE_DIR@,$GUILE_SITE_CCACHE_DIR,\ - -e s,@builtin@,$builtin,\ - bin/builtin.in > bin/$builtin - chmod +x bin/$builtin -done +if [ "$srcdir" = . ]; then + top_builddir=. +else + srcdest=${srcdest} + top_builddir=$PWD +fi +abs_top_srcdir=${abs_top_srcdir-$(cd ${srcdir} && pwd)} +abs_top_builddir=$PWD + cat > .config.make < gash/config.scm +subst () { + sed \ + -e s,"@srcdest@,$srcdest,"\ + -e s,"@srcdir@,$srcdir,"\ + -e s,"@abs_top_srcdir@,$abs_top_srcdir,"\ + -e s,"@abs_top_builddir@,$abs_top_builddir,"\ + -e s,"@top_builddir@,$top_builddir,"\ + -e s",@BASH@,$BASH,"\ + -e s",@GUILE@,$GUILE,"\ + -e s,"@prefix@,$prefix,"\ + -e s",@guile_site_dir@,$guile_site_dir,"\ + -e s",@guile_site_ccache_dir@,$guile_site_ccache_dir,"\ + -e s",@BZIP2@,$BZIP2,"\ + -e s",@COMPRESS@,$COMPRESS,"\ + -e s",@GZIP@,$GZIP,"\ + -e s",@XZ@,$XZ,"\ + -e s",@VERSION@,$VERSION,"\ + -e s",@guile_site_dir@,$guile_site_dir,"\ + -e s",@guile_site_ccache_dir@,$guile_site_ccache_dir,"\ + -e s",@builtin@,$builtin,"\ + $1 > $2 +} + +subst bin/gash.in bin/gash +chmod +x bin/gash + +SHELLS=" +bash +sh +" +BUILTINS=" +cat +compress +cp +find +grep +ls +reboot +tar +wc +which +" +for builtin in $BUILTINS $SHELLS; do + subst ${srcdest}bin/builtin.in bin/$builtin + chmod +x bin/$builtin +done + +subst ${srcdest}gash/config.scm.in gash/config.scm +subst ${srcdest}build-aux/pre-inst-env.in pre-inst-env +chmod +x pre-inst-env cat <vector lst)) +(define cat-command (wrap-command cat "cat")) +(define compress-command (wrap-command "compress" compress)) +(define cp-command (wrap-command "cp" cp)) +(define find-command (wrap-command "find" find)) +(define grep-command (wrap-command "grep" grep)) +(define ls-command (wrap-command "ls" ls)) +(define reboot-command (wrap-command "reboot" reboot)) +(define sed-command (wrap-command "sed" sed)) +(define tar-command (wrap-command "tar" tar)) +(define wc-command (wrap-command "wc" wc)) +(define which-command (wrap-command "which" which)) - (let loop ((indexes (unfold (cut >= <> columns) - (cut * <> items-per-column) - 1+ - 0))) - (unless (>= (first indexes) items-per-column) - (for-each (lambda (index) - (let ((item (if (< index len) - (vector-ref items index) - ""))) - (display (string-pad-right item column-width)))) - indexes) - (newline) - (loop (map 1+ indexes))))) - -(cond-expand - (guile - ;; Support -1, see https://lists.gnu.org/archive/html/bug-guile/2018-07/msg00009.html - (module-define! (resolve-module '(ice-9 getopt-long)) 'short-opt-rx (make-regexp "^-([a-zA-Z0-9]+)(.*)"))) - (else)) - -(define (ls-command-implementation . args) - ;; Run-time support procedure. - (lambda _ - (let* ((option-spec - '((all (single-char #\a)) - (help) - (long (single-char #\l)) - (one-file-per-line (single-char #\1)) - (version))) - (options (getopt-long (cons "ls" args) option-spec)) - (all? (option-ref options 'all #f)) - (help? (option-ref options 'help #f)) - (long? (option-ref options 'long #f)) - (one-file-per-line? (option-ref options 'one-file-per-line #f)) - (version? (option-ref options 'version #f)) - (files (option-ref options '() '()))) - (cond (version? (format #t "ls (GASH) ~a\n" %version)) - (help? (display "Usage: ls [OPTION]... [FILE]... - -Options: - -a, --all do not ignore entries starting with . - --help display this help and exit - -l, --long use a long listing format - --version display version information and exit - -1 list one file per line -")) - (else - (let* ((files (if (null? files) (scandir ".") - (append-map (lambda (file) - (catch 'system-error - (lambda () - (match (stat:type (lstat file)) - ('directory - ;; Like GNU ls, list the contents of - ;; FILE rather than FILE itself. - (match (scandir file - (match-lambda - ((or "." "..") #f) - (_ #t))) - (#f - (list file)) - ((files ...) - (map (cut string-append file "/" <>) - files)))) - (_ - (list file)))) - (lambda args - (let ((errno (system-error-errno args))) - (format (current-error-port) "~a: ~a~%" - file (strerror errno)) - '())))) - files))) - (files (if all? files - (filter (negate (cut string-prefix? "." <>)) files)))) - (cond (long? (for-each (lambda (f) (display-file f) (newline)) files)) - (one-file-per-line? (for-each stdout files)) - (else (display-tabulated files))))))))) - -(define ls-command (wrap-command ls-command-implementation "ls")) - -(define (which-command program . rest) - (lambda _ - (stdout (search-path (executable-path) program)))) - -(define (cat-command-implementation . args) - (lambda _ - (fold (lambda (file p) - (if (string=? file "-") (dump-port (current-input-port) (current-output-port)) - (call-with-input-file file - (lambda (port) - (dump-port port (current-output-port)))))) - 0 args))) - -(define cat-command (wrap-command cat-command-implementation "cat")) - -(define (rm-command-implementation . args) - (lambda _ - (cond ((member "-r" args) - (for-each delete-file-recursively - (apply delete (cons "-r" args)))) - (else - (for-each delete-file args))))) - -(define rm-command (wrap-command rm-command-implementation "rm")) - -(define (lines+chars port) - "Return the number of lines and number of chars read from PORT." - (let loop ((lines 0) (chars 0)) - (match (read-char port) - ((? eof-object?) ;done! - (values lines chars)) - (#\newline ;recurse - (loop (1+ lines) (1+ chars))) - (_ ;recurse - (loop lines (1+ chars)))))) - -(define (file-exists?* file) - "Like 'file-exists?' but emits a warning if FILE is not accessible." - (catch 'system-error - (lambda () - (stat file)) - (lambda args - (let ((errno (system-error-errno args))) - (format (current-error-port) "~a: ~a~%" - file (strerror errno)) - #f)))) - -(define (wc-print file) - (let-values (((lines chars) - (call-with-input-file file lines+chars))) - (format #t "~a ~a ~a~%" lines chars file))) - -(define (wc-l-print file) - (let-values (((lines chars) - (call-with-input-file file lines+chars))) - (format #t "~a ~a~%" lines file))) - -(define (wc-c-print file) - (let-values (((lines chars) - (call-with-input-file file lines+chars))) - (format #t "~a ~a~%" chars file))) - -(define (wc-command-implementation . files) - (for-each wc-print (filter file-exists?* files))) - -(define (wc-l-command-implementation . files) - (for-each wc-l-print (filter file-exists?* files))) - -(define (wc-c-command-implementation . files) - (for-each wc-c-print (filter file-exists?* files))) - -(define (wc-command . args) - "Emit code for the 'wc' command." - (lambda _ - (cond ((member "-l" args) - (apply wc-l-command-implementation (delete "-l" args))) - ((member "-c" args) - (apply wc-c-command-implementation (delete "-c" args))) - (else - (apply wc-command-implementation args))))) - -(define (reboot-command . args) - "Emit code for 'reboot'." - ;; Normally Bournish is used in the initrd, where 'reboot' is provided - ;; directly by (guile-user). In other cases, just bail out. - (if (defined? 'reboot) - (reboot) - (begin - (format (current-error-port) - "I don't know how to reboot, sorry about that!~%") - 1))) - -(define %not-colon (char-set-complement (char-set #\:))) -(define (executable-path) - "Return the search path for programs as a list." - (match (getenv "PATH") - (#f '()) - (str (string-tokenize str %not-colon)))) - -(define (cp-command-implementation source dest . rest) - (lambda _ (copy-file source dest))) - -(define cp-command (wrap-command cp-command-implementation "cp")) - -(define (find-command-implementation . args) - ;; Run-time support procedure. - (lambda _ - (let* ((option-spec - '((help) - (version))) - (options (getopt-long (cons "find" args) option-spec)) - (help? (option-ref options 'help #f)) - (version? (option-ref options 'version #f)) - (files (option-ref options '() '())) - (files (if (null? files) '(".") files)) - (file (car files))) - (when (> (length files) 1) - (format (current-error-port) "find: too many FILEs: ~s\n" files) - (error "find failed")) - ;; TODO: find [OPTION]... [FILE]... [EXPRESSION]... - ;; and options: esp: -x, -L - (cond (version? (format #t "find (GASH) ~a\n" %version)) - (help? (display "Usage: find [OPTION]... [FILE] - -Options: - --help display this help and exit - --version display version information and exit -")) - (else - (let* ((files (find-files file #:directories? #t #:fail-on-error? #t))) - (for-each stdout files))))))) - -(define find-command (wrap-command find-command-implementation "find")) - -(define (grep-command . args) - (lambda _ - (let* ((option-spec - '((help) - (line-number (single-char #\n)) - (files-with-matches (single-char #\l)) - (files-without-match (single-char #\L)) - (with-file-name (single-char #\H)) - (no-file-name (single-char #\h)) - (only-matching (single-char #\o)) - (version (single-char #\V)))) - (options (getopt-long (cons "grep" args) option-spec)) - (help? (option-ref options 'help #f)) - (version? (option-ref options 'version #f)) - (files (option-ref options '() '()))) - (cond (version? (format #t "grep (GASH) ~a\n" %version)) - (help? (display "Usage: grep [OPTION]... PATTERN [FILE]... - -Options: - --help display this help and exit - -h, --no-filename suppress the file name prefix on output - -H, --with-filename print file name with output lines - -l, --files-with-matches print only names of FILEs with selected lines - -L, --files-without-match print only names of FILEs with no selected lines - -n, --line-number print line number with output lines - -o, --only-matching show only the part of a line matching PATTERN - -V, --version display version information and exit -")) - ((null? files) #t) - (else - (let* ((pattern (car files)) - (files (if (pair? (cdr files)) (cdr files) - (list "-"))) - (matches (append-map (cut grep pattern <>) files))) - (define (display-match o) - (let* ((s (grep-match-string o)) - (s (if (option-ref options 'only-matching #f) - (substring s (grep-match-column o) (grep-match-end-column o)) - s)) - (s (if (option-ref options 'line-number #f) - (string-append (number->string (grep-match-line o)) ":" s) - s)) - (s (if (option-ref options 'with-file-name #f) - (string-append (grep-match-file-name o) ":" s) - s))) - (stdout s))) - (define (files-with-matches) - (delete-duplicates (map grep-match-file-name matches))) - (cond ((option-ref options 'files-with-matches #f) - (let ((result (files-with-matches))) - (and (pair? result) - (for-each stdout result) - 0))) - ((option-ref options 'files-without-match #f) - (let* ((result (files-with-matches)) - (result (filter (negate (cut member <> result)) files))) - (and (pair? result) - (for-each stdout result) - 0))) - (else - (and (pair? matches) - (for-each display-match matches) - 0))))))))) - -(define (multi-opt options name) - (let ((opt? (lambda (o) (and (eq? (car o) name) (cdr o))))) - (filter-map opt? options))) - -(define (tar-command . args) - (lambda _ - (let* ((option-spec - '((create (single-char #\c)) - (compress (single-char #\Z)) - (gzip (single-char #\z)) - (bzip2 (single-char #\j)) - (xz (single-char #\J)) - (group (value #t)) - (extract (single-char #\x)) - (file (single-char #\f) (value #t)) - (help (single-char #\h)) - (mtime (value #t)) - (list (single-char #\t)) - (numeric-owner?) - (owner (value #t)) - (sort (value #t)) - (verbose (single-char #\v)) - (version (single-char #\V)))) - (args (cons "tar" args)) - (options (getopt-long args option-spec)) - (options (if (or (option-ref options 'create #f) - (option-ref options 'extract #f) - (option-ref options 'list #f) - (null? (cdr args)) - (string-prefix? "-" (cadr args))) options - (let ((args (cons* (car args) - (string-append "-" (cadr args)) - (cddr args)))) - (getopt-long args option-spec)))) - (create? (option-ref options 'create #f)) - (list? (option-ref options 'list #f)) - (extract? (option-ref options 'extract #f)) - (file (option-ref options 'file "-")) - (files (option-ref options '() '())) - (compress? (option-ref options 'compress #f)) - (bzip2? (option-ref options 'bzip2 #f)) - (gzip? (option-ref options 'gzip #f)) - (xz? (option-ref options 'xz #f)) - (compression (cond (bzip2? 'bzip2) - (compress? 'compress) - (gzip? 'gzip) - (xz? 'xz) - (else (and (or extract? list? ) - (cond ((string-suffix? ".Z" file) 'compress) - ((string-suffix? ".bz2" file) 'bzip2) - ((string-suffix? ".gz" file) 'gzip) - ((string-suffix? ".xz" file) 'xz) - (else #f)))))) - (help? (option-ref options 'help #f)) - (usage? (and (not help?) (not (or (and create? (pair? files)) - extract? list?)))) - (verbosity (length (multi-opt options 'verbose))) - (version? (option-ref options 'version #f))) - (cond (version? (format #t "tar (GASH) ~a\n" %version) (exit 0)) - ((or help? usage?) (format (if usage? (current-error-port) #t) - "\ -Usage: tar [OPTION]... [FILE]... - -c, --create create a new archive - -f, --file=ARCHIVE use archive file or device ARCHIVE - --group=NAME force NAME as group for added files - -h, --help display this help - --mtime=DATE-OR-FILE set mtime for added files from DATE-OR-FILE - --numeric-owner always use numbers for user/group names - --owner=NAME force NAME as owner for added files - --sort=ORDER directory sorting order: none (default), name or - inode - -t, --list list the contents of an archive - -V, --version display version - -v, --verbose verbosely list files processed - -x, --extract extract files from an archive - -z, --gzip filter the archive through gzip - -Z, --compress filter the archive through compress -") - (exit (if usage? 2 0))) - (create? - (let ((files (if (not (option-ref options 'sort #f)) files - (sort files string<))) - (group (and=> (option-ref options 'group #f) string->number)) - (mtime (and=> (option-ref options 'mtime #f) string->number)) - (numeric-owner? (option-ref options 'numeric-owner? #f)) - (owner (and=> (option-ref options 'owner #f) string->number))) - (if (or compression (equal? file "-")) - (let ((port (if (equal? file "-") (current-output-port) - (open-file file "wb")))) - (call-with-compressed-output-port compression port - (cut apply write-ustar-port <> - `(,files - ,@(if group `(#:group ,group) '()) - ,@(if mtime `(#:mtime ,mtime) '()) - ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) - ,@(if owner `(#:owner ,owner) '()) - ,@(if owner `(#:owner ,owner) '()) - #:verbosity ,verbosity)))) - (apply write-ustar-archive - `(,file - ,files - ,@(if group `(#:group ,group) '()) - ,@(if mtime `(#:mtime ,mtime) '()) - ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) - ,@(if owner `(#:owner ,owner) '()) - ,@(if owner `(#:owner ,owner) '()) - #:verbosity ,verbosity))))) - (extract? - (if (or compression (equal? file "-")) - (let ((port (if (equal? file "-") (current-input-port) - (open-file file "rb")))) - (call-with-decompressed-port compression port - (cut read-ustar-port <> files #:verbosity verbosity))) - (read-ustar-archive file files #:verbosity verbosity))) - (list? - (if (or compression (equal? file "-")) - (let ((port (if (equal? file "-") (current-input-port) - (open-file file "rb")))) - (call-with-decompressed-port compression port - (cut list-ustar-port <> files #:verbosity (1+ verbosity)))) - (list-ustar-archive file files #:verbosity (1+ verbosity)))))))) - -(define (compress-command . args) - (lambda _ - (let* ((option-spec - '((bits (single-char #\b) (value #t)) - (decompress (single-char #\d)) - (help (single-char #\h)) - (stdout (single-char #\c)) - (verbose (single-char #\v)) - (version (single-char #\V)))) - (args (cons "compress" args)) - (options (getopt-long args option-spec)) - (bits (string->number (option-ref options 'bits "16"))) - (decompress? (option-ref options 'decompress #f)) - (stdout? (option-ref options 'stdout #f)) - (files (option-ref options '() '())) - (help? (option-ref options 'help #f)) - (usage? (and (not help?) (or (and (null? files) (isatty? (current-input-port)))))) - (verbose? (option-ref options 'verbose #f)) - (version? (option-ref options 'version #f))) - (cond (version? (format #t "compress (GASH) ~a\n" %version) (exit 0)) - ((or help? usage?) (format (if usage? (current-error-port) #t) - "\ -Usage: compress [OPTION]... [FILE]... - -b, --bits=BITS use a maximum of BITS bits per code [16] - -c, --stdout write on standard output, keep original files unchanged - -d, --decompress decompress - -h, --help display this help - -v, --verbose show compression ratio - -V, --version display version -") - (exit (if usage? 2 0))) - (decompress? (if (pair? files) (uncompress-file (car files) verbose?) - (uncompress-port (current-input-port) (current-output-port) verbose?))) - (else (if (pair? files) (compress-file (car files) bits verbose?) - (compress-port (current-input-port) (current-output-port) bits verbose?))))))) - -(define %bournish-commands +(define (%bournish-commands) `( ("cat" . ,cat-command) ("compress" . ,compress-command) @@ -543,6 +90,7 @@ Usage: compress [OPTION]... [FILE]... ("grep" . ,grep-command) ("ls" . ,ls-command) ("reboot" . ,reboot-command) + ("sed" . ,sed-command) ("tar" . ,tar-command) ("wc" . ,wc-command) ("which" . ,which-command) diff --git a/gash/builtins.scm b/gash/builtins.scm index 5aa7ac0..944884d 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -32,7 +32,7 @@ #:use-module (gash gash) ; %prefer-builtins? #:use-module (gash bournish-commands) #:use-module (gash environment) - #:use-module (gash guix-build-utils) + #:use-module (gash shell-utils) #:use-module (gash io) #:use-module (gash job) #:use-module (gash pipe) diff --git a/gash/commands/cat.scm b/gash/commands/cat.scm new file mode 100644 index 0000000..3af3f6b --- /dev/null +++ b/gash/commands/cat.scm @@ -0,0 +1,41 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial bournish.scm was taken from Guix. + +;;; Code: + +(define-module (gash commands cat) + #:use-module (srfi srfi-1) + #:use-module (gash shell-utils) + #:export (cat)) + +(define (cat name . args) + (fold (lambda (file p) + (if (string=? file "-") (dump-port (current-input-port) (current-output-port)) + (call-with-input-file file + (lambda (port) + (dump-port port (current-output-port)))))) + 0 args)) + +(define main cat) diff --git a/gash/commands/compress.scm b/gash/commands/compress.scm new file mode 100644 index 0000000..bfce7f0 --- /dev/null +++ b/gash/commands/compress.scm @@ -0,0 +1,68 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; Code: + +(define-module (gash commands compress) + #:use-module (ice-9 getopt-long) + #:use-module (srfi srfi-1) + + #:use-module (gash config) + #:use-module (gash compress) + #:use-module (gash guix-utils) + #:export ( + compress + )) + +(define (compress . args) + (let* ((option-spec + '((bits (single-char #\b) (value #t)) + (decompress (single-char #\d)) + (help (single-char #\h)) + (stdout (single-char #\c)) + (verbose (single-char #\v)) + (version (single-char #\V)))) + (options (getopt-long args option-spec)) + (bits (string->number (option-ref options 'bits "16"))) + (decompress? (option-ref options 'decompress #f)) + (stdout? (option-ref options 'stdout #f)) + (files (option-ref options '() '())) + (help? (option-ref options 'help #f)) + (usage? (and (not help?) (or (and (null? files) (isatty? (current-input-port)))))) + (verbose? (option-ref options 'verbose #f)) + (version? (option-ref options 'version #f))) + (cond (version? (format #t "compress (GASH) ~a\n" %version) (exit 0)) + ((or help? usage?) (format (if usage? (current-error-port) #t) + "\ +Usage: compress [OPTION]... [FILE]... + -b, --bits=BITS use a maximum of BITS bits per code [16] + -c, --stdout write on standard output, keep original files unchanged + -d, --decompress decompress + -h, --help display this help + -v, --verbose show compression ratio + -V, --version display version +") + (exit (if usage? 2 0))) + (decompress? (if (pair? files) (uncompress-file (car files) verbose?) + (uncompress-port (current-input-port) (current-output-port) verbose?))) + (else (if (pair? files) (compress-file (car files) bits verbose?) + (compress-port (current-input-port) (current-output-port) bits verbose?)))))) + +(define main compress) diff --git a/gash/commands/cp.scm b/gash/commands/cp.scm new file mode 100644 index 0000000..4e486ae --- /dev/null +++ b/gash/commands/cp.scm @@ -0,0 +1,36 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial bournish.scm was taken from Guix. + +;;; Code: + +(define-module (gash commands cp) + #:export ( + cp + )) + +(define (cp name source dest . rest) + (copy-file source dest)) + +(define main cp) diff --git a/gash/commands/find.scm b/gash/commands/find.scm new file mode 100644 index 0000000..19bc5a3 --- /dev/null +++ b/gash/commands/find.scm @@ -0,0 +1,65 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial bournish.scm was taken from Guix. + +;;; Code: + +(define-module (gash commands find) + #:use-module (ice-9 getopt-long) + + #:use-module (gash config) + #:use-module (gash io) + #:use-module (gash shell-utils) + + #:export ( + find + )) + +(define (find . args) + (let* ((option-spec + '((help) + (version))) + (options (getopt-long args option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '())) + (files (if (null? files) '(".") files)) + (file (car files))) + (when (> (length files) 1) + (format (current-error-port) "find: too many FILEs: ~s\n" files) + (error "find failed")) + ;; TODO: find [OPTION]... [FILE]... [EXPRESSION]... + ;; and options: esp: -x, -L + (cond (version? (format #t "find (GASH) ~a\n" %version)) + (help? (display "Usage: find [OPTION]... [FILE] + +Options: + --help display this help and exit + --version display version information and exit +")) + (else + (let* ((files (find-files file #:directories? #t #:fail-on-error? #t))) + (for-each stdout files)))))) + +(define main find) diff --git a/gash/commands/grep.scm b/gash/commands/grep.scm new file mode 100644 index 0000000..c310d21 --- /dev/null +++ b/gash/commands/grep.scm @@ -0,0 +1,109 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; Code: + +(define-module (gash commands grep) + #:use-module (ice-9 ftw) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + + #:use-module (gash guix-utils) + #:use-module (gash compress) + #:use-module (gash config) + #:use-module (gash io) + #:use-module (gash ustar) + #:use-module (gash util) + #:use-module (gash shell-utils) + + #:export ( + grep + )) + +(define (grep . args) + (let* ((option-spec + '((help) + (line-number (single-char #\n)) + (files-with-matches (single-char #\l)) + (files-without-match (single-char #\L)) + (with-file-name (single-char #\H)) + (no-file-name (single-char #\h)) + (only-matching (single-char #\o)) + (version (single-char #\V)))) + (options (getopt-long args option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (cond (version? (format #t "grep (GASH) ~a\n" %version)) + (help? (display "Usage: grep [OPTION]... PATTERN [FILE]... + +Options: + --help display this help and exit + -h, --no-filename suppress the file name prefix on output + -H, --with-filename print file name with output lines + -l, --files-with-matches print only names of FILEs with selected lines + -L, --files-without-match print only names of FILEs with no selected lines + -n, --line-number print line number with output lines + -o, --only-matching show only the part of a line matching PATTERN + -V, --version display version information and exit +")) + ((null? files) #t) + (else + (let* ((pattern (car files)) + (files (if (pair? (cdr files)) (cdr files) + (list "-"))) + (matches (append-map (cut grep+ pattern <>) files))) + (define (display-match o) + (let* ((s (grep-match-string o)) + (s (if (option-ref options 'only-matching #f) + (substring s (grep-match-column o) (grep-match-end-column o)) + s)) + (s (if (option-ref options 'line-number #f) + (string-append (number->string (grep-match-line o)) ":" s) + s)) + (s (if (option-ref options 'with-file-name #f) + (string-append (grep-match-file-name o) ":" s) + s))) + (stdout s))) + (define (files-with-matches) + (delete-duplicates (map grep-match-file-name matches))) + (cond ((option-ref options 'files-with-matches #f) + (let ((result (files-with-matches))) + (and (pair? result) + (for-each stdout result) + 0))) + ((option-ref options 'files-without-match #f) + (let* ((result (files-with-matches)) + (result (filter (negate (cut member <> result)) files))) + (and (pair? result) + (for-each stdout result) + 0))) + (else + (and (pair? matches) + (for-each display-match matches) + 0)))))))) + +(define main grep) diff --git a/gash/commands/ls.scm b/gash/commands/ls.scm new file mode 100644 index 0000000..c15e5e4 --- /dev/null +++ b/gash/commands/ls.scm @@ -0,0 +1,106 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial bournish.scm was taken from Guix. + +;;; Code: + +(define-module (gash commands ls) + #:use-module (ice-9 ftw) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 match) + + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + + #:use-module (gash config) + #:use-module (gash io) + #:use-module (gash shell-utils) + + #:export ( + ls + )) + +(cond-expand + (guile + ;; Support -1, see https://lists.gnu.org/archive/html/bug-guile/2018-07/msg00009.html + (module-define! (resolve-module '(ice-9 getopt-long)) 'short-opt-rx (make-regexp "^-([a-zA-Z0-9]+)(.*)"))) + (else)) + +(define (ls . args) + (let* ((option-spec + '((all (single-char #\a)) + (help) + (long (single-char #\l)) + (one-file-per-line (single-char #\1)) + (version))) + (options (getopt-long args option-spec)) + (all? (option-ref options 'all #f)) + (help? (option-ref options 'help #f)) + (long? (option-ref options 'long #f)) + (one-file-per-line? (option-ref options 'one-file-per-line #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (cond (version? (format #t "ls (GASH) ~a\n" %version)) + (help? (display "Usage: ls [OPTION]... [FILE]... + +Options: + -a, --all do not ignore entries starting with . + --help display this help and exit + -l, --long use a long listing format + --version display version information and exit + -1 list one file per line +")) + (else + (let* ((files (if (null? files) (scandir ".") + (append-map (lambda (file) + (catch 'system-error + (lambda () + (match (stat:type (lstat file)) + ('directory + ;; Like GNU ls, list the contents of + ;; FILE rather than FILE itself. + (match (scandir file + (match-lambda + ((or "." "..") #f) + (_ #t))) + (#f + (list file)) + ((files ...) + (map (cut string-append file "/" <>) + files)))) + (_ + (list file)))) + (lambda args + (let ((errno (system-error-errno args))) + (format (current-error-port) "~a: ~a~%" + file (strerror errno)) + '())))) + files))) + (files (if all? files + (filter (negate (cut string-prefix? "." <>)) files)))) + (cond (long? (for-each (lambda (f) (display-file f) (newline)) files)) + (one-file-per-line? (for-each stdout files)) + (else (display-tabulated files)))))))) + +(define main ls) diff --git a/gash/commands/reboot.scm b/gash/commands/reboot.scm new file mode 100644 index 0000000..ae6a9da --- /dev/null +++ b/gash/commands/reboot.scm @@ -0,0 +1,44 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial bournish.scm was taken from Guix. + +;;; Code: + +(define-module (gash commands reboot) + #:export ( + reboot + )) + +(define (reboot name . args) + "Emit code for 'reboot'." + ;; Normally Bournish is used in the initrd, where 'reboot' is provided + ;; directly by (guile-user). In other cases, just bail out. + (if (defined? 'reboot) + (reboot) + (begin + (format (current-error-port) + "I don't know how to reboot, sorry about that!~%") + 1))) + +(define main reboot) diff --git a/gash/commands/tar.scm b/gash/commands/tar.scm new file mode 100644 index 0000000..32449ec --- /dev/null +++ b/gash/commands/tar.scm @@ -0,0 +1,152 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; Code: + +(define-module (gash commands tar) + #:use-module (ice-9 getopt-long) + #:use-module (srfi srfi-26) + #:use-module (gash config) + #:use-module (gash compress) + #:use-module (gash ustar) + #:use-module (gash guix-utils) + #:use-module (gash shell-utils) + + #:export ( + tar + )) + +(define (tar . args) + (let* ((option-spec + '((create (single-char #\c)) + (compress (single-char #\Z)) + (gzip (single-char #\z)) + (bzip2 (single-char #\j)) + (xz (single-char #\J)) + (group (value #t)) + (extract (single-char #\x)) + (file (single-char #\f) (value #t)) + (help (single-char #\h)) + (mtime (value #t)) + (list (single-char #\t)) + (numeric-owner?) + (owner (value #t)) + (sort (value #t)) + (verbose (single-char #\v)) + (version (single-char #\V)))) + (options (getopt-long args option-spec)) + (options (if (or (option-ref options 'create #f) + (option-ref options 'extract #f) + (option-ref options 'list #f) + (null? (cdr args)) + (string-prefix? "-" (cadr args))) options + (let ((args (cons* (car args) + (string-append "-" (cadr args)) + (cddr args)))) + (getopt-long args option-spec)))) + (create? (option-ref options 'create #f)) + (list? (option-ref options 'list #f)) + (extract? (option-ref options 'extract #f)) + (file (option-ref options 'file "-")) + (files (option-ref options '() '())) + (compress? (option-ref options 'compress #f)) + (bzip2? (option-ref options 'bzip2 #f)) + (gzip? (option-ref options 'gzip #f)) + (xz? (option-ref options 'xz #f)) + (compression (cond (bzip2? 'bzip2) + (compress? 'compress) + (gzip? 'gzip) + (xz? 'xz) + (else (and (or extract? list? ) + (cond ((string-suffix? ".Z" file) 'compress) + ((string-suffix? ".bz2" file) 'bzip2) + ((string-suffix? ".gz" file) 'gzip) + ((string-suffix? ".xz" file) 'xz) + (else #f)))))) + (help? (option-ref options 'help #f)) + (usage? (and (not help?) (not (or (and create? (pair? files)) + extract? list?)))) + (verbosity (length (multi-opt options 'verbose))) + (version? (option-ref options 'version #f))) + (cond (version? (format #t "tar (GASH) ~a\n" %version) (exit 0)) + ((or help? usage?) (format (if usage? (current-error-port) #t) + "\ +Usage: tar [OPTION]... [FILE]... + -c, --create create a new archive + -f, --file=ARCHIVE use archive file or device ARCHIVE + --group=NAME force NAME as group for added files + -h, --help display this help + --mtime=DATE-OR-FILE set mtime for added files from DATE-OR-FILE + --numeric-owner always use numbers for user/group names + --owner=NAME force NAME as owner for added files + --sort=ORDER directory sorting order: none (default), name or + inode + -t, --list list the contents of an archive + -V, --version display version + -v, --verbose verbosely list files processed + -x, --extract extract files from an archive + -z, --gzip filter the archive through gzip + -Z, --compress filter the archive through compress +") + (exit (if usage? 2 0))) + (create? + (let ((files (if (not (option-ref options 'sort #f)) files + (sort files string<))) + (group (and=> (option-ref options 'group #f) string->number)) + (mtime (and=> (option-ref options 'mtime #f) string->number)) + (numeric-owner? (option-ref options 'numeric-owner? #f)) + (owner (and=> (option-ref options 'owner #f) string->number))) + (if (or compression (equal? file "-")) + (let ((port (if (equal? file "-") (current-output-port) + (open-file file "wb")))) + (call-with-compressed-output-port compression port + (cut apply write-ustar-port <> + `(,files + ,@(if group `(#:group ,group) '()) + ,@(if mtime `(#:mtime ,mtime) '()) + ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) + ,@(if owner `(#:owner ,owner) '()) + ,@(if owner `(#:owner ,owner) '()) + #:verbosity ,verbosity)))) + (apply write-ustar-archive + `(,file + ,files + ,@(if group `(#:group ,group) '()) + ,@(if mtime `(#:mtime ,mtime) '()) + ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) + ,@(if owner `(#:owner ,owner) '()) + ,@(if owner `(#:owner ,owner) '()) + #:verbosity ,verbosity))))) + (extract? + (if (or compression (equal? file "-")) + (let ((port (if (equal? file "-") (current-input-port) + (open-file file "rb")))) + (call-with-decompressed-port compression port + (cut read-ustar-port <> files #:verbosity verbosity))) + (read-ustar-archive file files #:verbosity verbosity))) + (list? + (if (or compression (equal? file "-")) + (let ((port (if (equal? file "-") (current-input-port) + (open-file file "rb")))) + (call-with-decompressed-port compression port + (cut list-ustar-port <> files #:verbosity (1+ verbosity)))) + (list-ustar-archive file files #:verbosity (1+ verbosity))))))) + +(define main tar) diff --git a/gash/commands/wc.scm b/gash/commands/wc.scm new file mode 100644 index 0000000..8d4c386 --- /dev/null +++ b/gash/commands/wc.scm @@ -0,0 +1,81 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial bournish.scm was taken from Guix. + +;;; Code: + +(define-module (gash commands wc) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + + #:use-module (ice-9 match) + #:use-module (gash shell-utils) + #:export ( + wc + )) + +(define (lines+chars port) + "Return the number of lines and number of chars read from PORT." + (let loop ((lines 0) (chars 0)) + (match (read-char port) + ((? eof-object?) ;done! + (values lines chars)) + (#\newline ;recurse + (loop (1+ lines) (1+ chars))) + (_ ;recurse + (loop lines (1+ chars)))))) + +(define (wc-print file) + (let-values (((lines chars) + (call-with-input-file file lines+chars))) + (format #t "~a ~a ~a~%" lines chars file))) + +(define (wc-l-print file) + (let-values (((lines chars) + (call-with-input-file file lines+chars))) + (format #t "~a ~a~%" lines file))) + +(define (wc-c-print file) + (let-values (((lines chars) + (call-with-input-file file lines+chars))) + (format #t "~a ~a~%" chars file))) + +(define (wc- . files) + (for-each wc-print (filter file-exists?* files))) + +(define (wc-l . files) + (for-each wc-l-print (filter file-exists?* files))) + +(define (wc-c . files) + (for-each wc-c-print (filter file-exists?* files))) + +(define (wc name . args) + (cond ((member "-l" args) + (apply wc-l (delete "-l" args))) + ((member "-c" args) + (apply wc-c (delete "-c" args))) + (else + (apply wc- args)))) + +(define main wc) diff --git a/gash/commands/which.scm b/gash/commands/which.scm new file mode 100644 index 0000000..a4fa981 --- /dev/null +++ b/gash/commands/which.scm @@ -0,0 +1,38 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial bournish.scm was taken from Guix. + +;;; Code: + +(define-module (gash commands which) + #:use-module (gash io) + #:use-module (gash shell-utils) + #:export ( + which + )) + +(define (which name program . rest) + (stdout (search-path (executable-path) program))) + +(define main which) diff --git a/gash/config.scm.in b/gash/config.scm.in index 264e4b0..0d7ec41 100644 --- a/gash/config.scm.in +++ b/gash/config.scm.in @@ -18,6 +18,7 @@ (define-module (gash config) #:export (%bzip2 + %commands %xz %compress %gzip @@ -43,6 +44,12 @@ ((file-exists? compress) compress) ((file-exists? reloc) reloc)))) +(define %commands + (let* ((guile-site-ccache-dir "@guile_site_ccache_dir@") + (commands-dir (string-append guile-site-ccache-dir "/gash/commands"))) + (cond ((getenv "COMMANDS")) + (else commands-dir)))) + (define %gzip "@GZIP@") diff --git a/gash/gash.scm b/gash/gash.scm index eea1972..b3a6cd1 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -52,7 +52,7 @@ (call-with-input-file file-name parse)) (define (display-help) - (let ((builtins (sort (map car (append %bournish-commands ;;%builtin-commands + (let ((builtins (sort (map car (append (%bournish-commands) ;;%builtin-commands )) string<))) (display (string-append "\ Usage: gash [OPTION]... [FILE]... @@ -130,7 +130,7 @@ copyleft. (builtin-command-line (let* ((builtin (car builtin-command-line)) (args (cdr builtin-command-line)) - (command (assoc-ref %bournish-commands builtin))) + (command (assoc-ref (%bournish-commands) builtin))) ((apply command args)))) (#t (let* ((HOME (string-append (getenv "HOME") "/.gash_history")) (thunk (lambda () diff --git a/gash/guix-utils.scm b/gash/guix-utils.scm index 4b3c90a..285f627 100644 --- a/gash/guix-utils.scm +++ b/gash/guix-utils.scm @@ -31,13 +31,12 @@ ;;; Code: - (define-module (gash guix-utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (ice-9 format) #:autoload (ice-9 popen) (open-pipe*) - #:use-module ((gash guix-build-utils) #:select (dump-port)) + #:use-module ((gash shell-utils) #:select (dump-port)) #:use-module (ice-9 match) #:use-module (gash config) #:export (filtered-port diff --git a/gash/io.scm b/gash/io.scm index d947369..749320b 100644 --- a/gash/io.scm +++ b/gash/io.scm @@ -1,8 +1,6 @@ (define-module (gash io) #:use-module (srfi srfi-1) - #:use-module (gash gash) - #:export (pke stdout stderr)) (define (output port o) diff --git a/gash/script.scm b/gash/script.scm index 289343f..e046fd5 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -33,7 +33,6 @@ #:use-module (gash config) #:use-module (gash environment) #:use-module (gash gash) - #:use-module (gash guix-build-utils) #:use-module (gash io) #:use-module (gash job) #:use-module (gash pipe) @@ -249,7 +248,7 @@ (format (current-error-port) "gash: ~a: permission denied\n" command)) #f) ((and command (or (assoc-ref %builtin-commands command) - (assoc-ref %bournish-commands command))) + (assoc-ref (%bournish-commands) command))) => (lambda (command) (if args diff --git a/gash/guix-build-utils.scm b/gash/shell-utils.scm similarity index 82% rename from gash/guix-build-utils.scm rename to gash/shell-utils.scm index 6ec2903..0ebb705 100644 --- a/gash/guix-build-utils.scm +++ b/gash/shell-utils.scm @@ -26,7 +26,7 @@ ;;; Code: -(define-module (gash guix-build-utils) +(define-module (gash shell-utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-26) @@ -41,12 +41,15 @@ #:use-module (rnrs io ports) #:export ( delete-file-recursively + display-tabulated display-file dump-port + executable-path file-name-predicate find-files + file-exists?* grep* - grep + grep+ grep-match-file-name grep-match-string @@ -54,6 +57,7 @@ grep-match-column grep-match-end-column mkdir-p + multi-opt directory-exists? executable-file? @@ -216,7 +220,7 @@ transferred and the continuation of the transfer as a thunk." (match:end m)) matches) matches)))))) -(define (grep pattern file) +(define (grep+ pattern file) (cond ((and (string? file) (not (equal? file "-"))) (call-with-input-file file (lambda (in) @@ -248,6 +252,53 @@ transferred and the continuation of the transfer as a thunk." (apply throw args)))))) (() #t)))) +(define (file-exists?* file) + "Like 'file-exists?' but emits a warning if FILE is not accessible." + (catch 'system-error + (lambda () + (stat file)) + (lambda args + (let ((errno (system-error-errno args))) + (format (current-error-port) "~a: ~a~%" + file (strerror errno)) + #f)))) + +(define* (display-tabulated lst + #:key + (terminal-width 80) + (column-gap 2)) + "Display the list of string LST in as many columns as needed given +TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." + (define len (length lst)) + (define column-width + ;; The width of a column. Assume all the columns have the same width + ;; (GNU ls is smarter than that.) + (+ column-gap (reduce max 0 (map string-length lst)))) + (define columns + (max 1 + (quotient terminal-width column-width))) + (define pad + (if (zero? (modulo len columns)) + 0 + columns)) + (define items-per-column + (quotient (+ len pad) columns)) + (define items (list->vector lst)) + + (let loop ((indexes (unfold (cut >= <> columns) + (cut * <> items-per-column) + 1+ + 0))) + (unless (>= (first indexes) items-per-column) + (for-each (lambda (index) + (let ((item (if (< index len) + (vector-ref items index) + ""))) + (display (string-pad-right item column-width)))) + indexes) + (newline) + (loop (map 1+ indexes))))) + (define* (display-file file-name #:optional st) (define (display-rwx perm sticky) (display (if (zero? (logand perm 4)) "-" "r")) @@ -289,3 +340,14 @@ transferred and the continuation of the transfer as a thunk." (display date) (display " ")) (display file-name)) + +(define (multi-opt options name) + (let ((opt? (lambda (o) (and (eq? (car o) name) (cdr o))))) + (filter-map opt? options))) + +(define %not-colon (char-set-complement (char-set #\:))) +(define (executable-path) + "Return the search path for programs as a list." + (match (getenv "PATH") + (#f '()) + (str (string-tokenize str %not-colon)))) diff --git a/gash/ustar.scm b/gash/ustar.scm index 73ab410..6701c85 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -33,7 +33,7 @@ #:use-module (ice-9 receive) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) - #:use-module (gash guix-build-utils) + #:use-module (gash shell-utils) #:export (read-ustar-archive read-ustar-port write-ustar-archive diff --git a/gash/util.scm b/gash/util.scm index 6bd68ad..08dbac6 100644 --- a/gash/util.scm +++ b/gash/util.scm @@ -15,11 +15,3 @@ (define (conjoin . predicates) (lambda (. arguments) (every (cut apply <> arguments) predicates))) - -(define (wrap-command command name) - (lambda args - (catch #t - (cut apply command args) - (lambda (key . args) - (format (current-error-port) "~a: ~a ~a\n" name key args) - 1)))) diff --git a/makefile b/makefile index 8a081f5..0fe88bd 100644 --- a/makefile +++ b/makefile @@ -9,7 +9,7 @@ bin/gash: bin/gash.in | do-configure bin/tar: bin/tar.in | do-configure do-configure: - ./configure --prefix=$(PREFIX) + ./configure --prefix=$(prefix) all: all-go do-configure @@ -33,21 +33,21 @@ check-gash: all SHELL=bin/gash ./test.sh install: all - mkdir -p $(DESTDIR)$(BINDIR) - cp bin/gash $(DESTDIR)$(BINDIR)/gash - mkdir -p $(DESTDIR)$(GUILE_SITE_DIR) - tar -cf- gash/*.scm | tar -C $(DESTDIR)$(GUILE_SITE_DIR) -xf- - mkdir -p $(DESTDIR)$(GUILE_SITE_CCACHE_DIR) - cp bin/gash.go $(DESTDIR)$(GUILE_SITE_CCACHE_DIR) - tar -cf- gash/*.go | tar -C $(DESTDIR)$(GUILE_SITE_CCACHE_DIR) -xf- - mkdir -p $(DESTDIR)$(DOCDIR) - cp -f COPYING README TODO $(DOCDIR) + mkdir -p $(DESTDIR)$(bindir) + cp bin/gash $(DESTDIR)$(bindir)/gash + mkdir -p $(DESTDIR)$(guile_site_dir) + tar -cf- gash/*.scm | tar -C $(DESTDIR)$(guile_site_dir) -xf- + mkdir -p $(DESTDIR)$(guile_site_ccache_dir) + cp bin/gash.go $(DESTDIR)$(guile_site_ccache_dir) + tar -cf- gash/*.go | tar -C $(DESTDIR)$(guile_site_ccache_dir) -xf- + mkdir -p $(DESTDIR)$(docdir) + cp -f COPYING README TODO $(docdir) $(MAKE) install-info install-info: info - mkdir -p $(DESTDIR)$(PREFIX)/share/info - tar -cf- doc/gash.info* | tar -xf- --strip-components=1 -C $(DESTDIR)$(PREFIX)/share/info - install-info --info-dir=$(DESTDIR)$(PREFIX)/share/info doc/gash.info + mkdir -p $(DESTDIR)$(prefix)/share/info + tar -cf- doc/gash.info* | tar -xf- --strip-components=1 -C $(DESTDIR)$(prefix)/share/info + install-info --info-dir=$(DESTDIR)$(prefix)/share/info doc/gash.info doc/version.texi: doc/gash.texi makefile (set `LANG= date -r $< +'%d %B %Y'`;\ @@ -79,7 +79,7 @@ help: export BUILD_DEBUG export GUILE export GUILE_TOOLS -export GUILE_LOAD_PATH -export GUILE_LOAD_COMPILED_PATH +export guile_load_path +export guile_load_compiled_path From 9d1d2be6a6a345fed2f31f9f375b2572ba146c04 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 31 Oct 2018 07:30:14 +0100 Subject: [PATCH 182/312] test: Add expectations. * check.sh: New file, from test.sh. * test.sh: Run single test with expectations. --- .gitignore | 3 ++ check.sh | 81 ++++++++++++++++++++++++++++++++++ makefile | 8 ++-- test.sh | 40 ++++++++++------- test/06-assignment-echo.stdout | 1 + 5 files changed, 112 insertions(+), 21 deletions(-) create mode 100755 check.sh create mode 100644 test/06-assignment-echo.stdout diff --git a/.gitignore b/.gitignore index d5690d4..8815e7c 100644 --- a/.gitignore +++ b/.gitignore @@ -17,3 +17,6 @@ /doc/version.texi /gash/config.scm /pre-inst-env +/test/*.1 +/test/*.2 +/test/*.log diff --git a/check.sh b/check.sh new file mode 100755 index 0000000..62fd478 --- /dev/null +++ b/check.sh @@ -0,0 +1,81 @@ +if [ -n "$V" ]; then + set -x +fi +DIFF=diff +SHELL=${SHELL-bin/gash} +#SHELL=bin/gash + +tests=" +assign +assign2 +for +for-split-sequence +find +if2 +iohere +list +ls +nesting +pipe +substitution +00-exit +01-exit-0 +02-exit-1 +03-echo +04-echo-var +05-assignment-doublequoted-doublequotes +05-assignment +06-assignment-echo +06-assignment-singlequote +07-assignment-double-quote +08-assignment-variable-word +09-compound-word +0a-assign-substitute +0b-command-compound-word +10-if +11-if-false +20-pipe-exit-0 +21-pipe-exit-1 +22-semi-pipe-exit-0 +30-assignment-substitution +30-eval +31-eval-echo-variable +32-for-substitute +33-string-args +35-assignment-eval-echo +" + +broken=" + +" + +expect=$(echo $broken | wc -w) +pass=0 +fail=0 +total=0 +for t in $tests; do + sh test.sh "test/$t" &> test/"$t".log + r=$? + total=$((total+1)) + if [ $r = 0 ]; then + echo $t: [OK] + pass=$((pass+1)) + else + echo $t: [FAIL] + fail=$((fail+1)) + fi +done + +[ $expect != 0 ] && echo "expect: $expect" +[ $fail != 0 ] && echo "failed: $fail" +[ $fail -lt $expect ] && echo "solved: $(($expect - $fail))" +echo "passed: $pass" +echo "total: $total" +if [ $fail != 0 -a $fail -gt $expect ]; then + echo FAILED: $fail/$total + exit 1 +elif [ $fail != 0 ]; then + echo PASS: $pass/$total +else + echo PASS: $total +fi diff --git a/makefile b/makefile index 0fe88bd..62a7df9 100644 --- a/makefile +++ b/makefile @@ -11,9 +11,9 @@ bin/tar: bin/tar.in | do-configure do-configure: ./configure --prefix=$(prefix) -all: all-go do-configure +all: all-go -all-go: +all-go: | do-configure build-aux/build-guile.sh clean: @@ -26,11 +26,11 @@ check: all check-bash check-gash check-bash: all ifneq ($(BASH),) - SHELL=$(BASH) ./test.sh + SHELL=$(BASH) ./check.sh endif check-gash: all - SHELL=bin/gash ./test.sh + SHELL=bin/gash ./check.sh install: all mkdir -p $(DESTDIR)$(bindir) diff --git a/test.sh b/test.sh index cda17f0..babfbe9 100755 --- a/test.sh +++ b/test.sh @@ -1,19 +1,25 @@ -if [ -n "$BUILD_DEBUG" ]; then +set -e +if [ -n "$V" ]; then set -x fi -#SHELL=${SHELL-bin/gash} -SHELL=bin/gash -for f in test/*.sh; do - echo -n "$f: " - b=test/$(basename $f .sh) -# $SHELL --geesh -e $f - $SHELL -e $f - r=$? - if [ -f $b.exit ]; then - e=$(cat $b.exit) - else - e=0 - fi - [ $r = $e ] || exit 1 - echo pass -done +DIFF=${DIFF-diff} +SHELL=${SHELL-bin/gash} + +t=$1 +b=test/$(basename $t .sh) +set +e +$SHELL -e $b.sh > $b.1 2> $b.2 +r=$? +set -e +if [ -f $b.exit ]; then + e=$(cat $b.exit) +else + e=0 +fi +[ $r = $e ] || exit 1 +if [ -f $b.stdout ]; then + $DIFF -u $b.stdout $b.1 +fi +if [ -f $b.stderr ]; then + $DIFF -u $b.stderr $b.2 +fi diff --git a/test/06-assignment-echo.stdout b/test/06-assignment-echo.stdout new file mode 100644 index 0000000..01dca2d --- /dev/null +++ b/test/06-assignment-echo.stdout @@ -0,0 +1 @@ +/bin/bash From f27cb9a19279ecebe882612f37a3fe36c1685375 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 30 Oct 2018 23:57:50 +0100 Subject: [PATCH 183/312] sed: New builtin. * gash/commands/sed.scm: New file. * build-aux/build-guile.sh: Compile it. * configure: Create script. * gash/shell-utils.scm (with-atomic-file-replacement, substitute*): New function, Import from Guix. (substitute-port): New function. --- .gitignore | 1 + build-aux/build-guile.sh | 2 + check.sh | 17 +++- configure | 1 + gash/commands/sed.scm | 130 ++++++++++++++++++++++++++++++ gash/shell-utils.scm | 86 +++++++++++++++++++- test/00-sed-case.sh | 1 + test/00-sed-case.stdout | 1 + test/00-sed-global.sh | 1 + test/00-sed-global.stdout | 1 + test/00-sed-group-extended.sh | 1 + test/00-sed-group-extended.stdout | 1 + test/00-sed-group.sh | 1 + test/00-sed-group.stdout | 1 + test/00-sed-once.sh | 1 + test/00-sed-once.stdout | 1 + test/00-sed-twice.sh | 1 + test/00-sed-twice.stdout | 1 + test/00-sed-undo.sh | 1 + test/00-sed-undo.stdout | 1 + test/00-sed.sh | 1 + test/00-sed.stdout | 7 ++ 22 files changed, 256 insertions(+), 3 deletions(-) create mode 100644 gash/commands/sed.scm create mode 100644 test/00-sed-case.sh create mode 100644 test/00-sed-case.stdout create mode 100644 test/00-sed-global.sh create mode 100644 test/00-sed-global.stdout create mode 100644 test/00-sed-group-extended.sh create mode 100644 test/00-sed-group-extended.stdout create mode 100644 test/00-sed-group.sh create mode 100644 test/00-sed-group.stdout create mode 100644 test/00-sed-once.sh create mode 100644 test/00-sed-once.stdout create mode 100644 test/00-sed-twice.sh create mode 100644 test/00-sed-twice.stdout create mode 100644 test/00-sed-undo.sh create mode 100644 test/00-sed-undo.stdout create mode 100644 test/00-sed.sh create mode 100644 test/00-sed.stdout diff --git a/.gitignore b/.gitignore index 8815e7c..7339ac8 100644 --- a/.gitignore +++ b/.gitignore @@ -9,6 +9,7 @@ /bin/grep /bin/ls /bin/reboot +/bin/sed /bin/sh /bin/tar /bin/wc diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 5b55be7..50533d7 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -65,6 +65,7 @@ gash/commands/find.scm gash/commands/grep.scm gash/commands/ls.scm gash/commands/reboot.scm +gash/commands/sed.scm gash/commands/tar.scm gash/commands/wc.scm gash/commands/which.scm @@ -90,6 +91,7 @@ bin/gash bin/grep bin/ls bin/reboot +bin/sed bin/tar bin/wc bin/which diff --git a/check.sh b/check.sh index 62fd478..6a1679a 100755 --- a/check.sh +++ b/check.sh @@ -3,7 +3,6 @@ if [ -n "$V" ]; then fi DIFF=diff SHELL=${SHELL-bin/gash} -#SHELL=bin/gash tests=" assign @@ -43,12 +42,26 @@ substitution 32-for-substitute 33-string-args 35-assignment-eval-echo + +00-sed +00-sed-once +00-sed-global +00-sed-case +00-sed-group +00-sed-group-extended +00-sed-twice +00-sed-undo " broken=" - " +if [ "$(basename $SHELL)" = bash ]; then + broken=" +00-sed +" +fi + expect=$(echo $broken | wc -w) pass=0 fail=0 diff --git a/configure b/configure index b4d2d68..b6e7769 100755 --- a/configure +++ b/configure @@ -96,6 +96,7 @@ find grep ls reboot +sed tar wc which diff --git a/gash/commands/sed.scm b/gash/commands/sed.scm new file mode 100644 index 0000000..5f3f7d5 --- /dev/null +++ b/gash/commands/sed.scm @@ -0,0 +1,130 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; Code: + +(define-module (gash commands sed) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 regex) + + #:use-module (gash config) + #:use-module (gash guix-utils) + #:use-module (gash shell-utils) + + #:export ( + sed + )) + +(define (replace->lambda string modifiers) + (define (replace->string m s) + (list->string + (let loop ((lst (string->list string))) + (cond ((null? lst) '()) + ((null? (cdr lst)) lst) + ((and (eq? (car lst) #\\) + (char-numeric? (cadr lst))) + (let ((i (- (char->integer (cadr lst)) (char->integer #\0)))) + (append (string->list (match:substring m i)) (loop (cddr lst))))) + ((and (eq? (car lst) #\\) + (eq? (cadr lst) #\\)) + (append '(#\\ #\\) (cddr lst))) + (else (cons (car lst) (loop (cdr lst)))))))) + (lambda (l m+) + ;; Iterate over matches M+ and + ;; return the modified line + ;; based on L. + (let loop ((m* m+) ; matches + (o 0) ; offset in L + (r '())) ; result + (match m* + (() + (let ((r (cons (substring l o) r))) + (string-concatenate-reverse r))) + ((m . rest) + (let* ((refs (- (vector-length m) 2)) + (replace (replace->string m string)) + (replace (cons* replace (substring l o (match:start m)) r))) + (if (memq #\g modifiers) (loop rest (match:end m) replace) + (loop '() (match:end m) replace)))))))) + +(define (sed . args) + (let* ((option-spec + '((expression (single-char #\e) (value #t)) + (extended (single-char #\r)) + (posix-extended (single-char #\E)) + (file (single-char #\f) (value #t)) + (help (single-char #\h)) + (in-place (single-char #\i)) + (version (single-char #\V)))) + (options (getopt-long args option-spec)) + (files (option-ref options '() '())) + (extended? (or (option-ref options 'extended #f) + (option-ref options 'posix-extended #f))) + (help? (option-ref options 'help #f)) + (in-place? (option-ref options 'in-place #f)) + (usage? (and (not help?) (or (and (null? files) (isatty? (current-input-port)))))) + (version? (option-ref options 'version #f))) + (cond (version? (format #t "sed (GASH) ~a\n" %version) (exit 0)) + ((or help? usage?) (format (if usage? (current-error-port) #t) + "\ +Usage: sed [OPTION]... [SCRIPT] [FILE]... + -e, --expression=SCRIPT add SCRIPT to the commands to be executed + -E, -r, --regexp-extended use extended regular expressions in the script + -f, --file=SCRIPT add contents of SCRIPT to the commands to be executed + -h, --help display this help + -i, --in-place edit files in place + -V, --version display version +") + (exit (if usage? 2 0))) + (else + (let* ((script-files (multi-opt options 'file)) + (scripts (multi-opt options 'expression))) + (receive (scripts files) + (if (pair? (append script-files scripts)) (values scripts files) + (values (list-head files 1) (cdr files))) + (define (script->command o) + (cond ((string-prefix? "s" o) + (let* ((command (substring o 1)) + (string (substring command 1)) + (separator (string-ref command 0))) + (receive (search replace modifier-string) + (apply values (string-split string separator)) + (let* ((modifiers (string->list modifier-string)) + (flags (if extended? (list regexp/extended) (list regexp/basic))) + (flags (if (memq #\i modifiers) (cons regexp/icase flags) + flags))) + `((,search . ,flags) . ,(replace->lambda replace modifiers)))))) + (else (error (format #f "SED: command not supported: ~s\n" o))))) + (when (pair? script-files) + (error "SED: script files not supported")) + (let ((commands (map script->command scripts))) + (cond ((and in-place? (pair? files)) + (for-each (lambda (file) (substitute* file commands)) files)) + ((pair? files) + (for-each (lambda (file) + (with-input-from-file file + (lambda _ (substitute-port commands)))) + files)) + (else (substitute-port commands)))))))))) + +(use-modules (ice-9 rdelim)) +(define main sed) diff --git a/gash/shell-utils.scm b/gash/shell-utils.scm index 0ebb705..e115a17 100644 --- a/gash/shell-utils.scm +++ b/gash/shell-utils.scm @@ -63,6 +63,10 @@ executable-file? regular-file? symbolic-link? + substitute* + substitute-port + with-atomic-file-replacement + let-matches )) ;;; Commentary: @@ -343,7 +347,7 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." (define (multi-opt options name) (let ((opt? (lambda (o) (and (eq? (car o) name) (cdr o))))) - (filter-map opt? options))) + (filter-map opt? (reverse options)))) (define %not-colon (char-set-complement (char-set #\:))) (define (executable-path) @@ -351,3 +355,83 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." (match (getenv "PATH") (#f '()) (str (string-tokenize str %not-colon)))) + + +;;; +;;; Text substitution (aka. sed). +;;; + +(define (with-atomic-file-replacement file proc) + "Call PROC with two arguments: an input port for FILE, and an output +port for the file that is going to replace FILE. Upon success, FILE is +atomically replaced by what has been written to the output port, and +PROC's result is returned." + (let* ((template (string-append file ".XXXXXX")) + (out (mkstemp! template)) + (mode (stat:mode (stat file)))) + (with-throw-handler #t + (lambda () + (call-with-input-file file + (lambda (in) + (let ((result (proc in out))) + (close out) + (chmod template mode) + (rename-file template file) + result)))) + (lambda (key . args) + (false-if-exception (delete-file template)))))) + +(define (substitute* file pattern+procs) + "PATTERN+PROCS is a list of regexp/two-argument-procedure pairs. For each +line of FILE, and for each PATTERN that it matches, call the corresponding +PROC as (PROC LINE MATCHES); PROC must return the line that will be written as +a substitution of the original line. Be careful about using '$' to match the +end of a line; by itself it won't match the terminating newline of a line." + (let ((rx+proc (map (match-lambda + ;; (((? regexp? pattern) . proc) + ;; (cons pattern proc)) + (((pattern . flags) . proc) + (cons (apply make-regexp pattern flags) + proc))) + pattern+procs))) + (with-atomic-file-replacement file + (lambda (in out) + (let loop ((line (read-line in 'concat))) + (if (eof-object? line) + #t + (let ((line (fold (lambda (r+p line) + (match r+p + ((regexp . proc) + (match (list-matches regexp line) + ((and m+ (_ _ ...)) + (proc line m+)) + (_ line))))) + line + rx+proc))) + (display line out) + (loop (read-line in 'concat))))))))) + +(define (substitute-port pattern+procs) + (let ((rx+proc (map (match-lambda + ;; (((? regexp? pattern) . proc) + ;; (cons pattern proc)) + (((pattern . flags) . proc) + (cons (apply make-regexp pattern flags) + proc))) + pattern+procs)) + (in (current-input-port)) + (out (current-output-port))) + (let loop ((line (read-line in 'concat))) + (if (eof-object? line) + #t + (let ((line (fold (lambda (r+p line) + (match r+p + ((regexp . proc) + (match (list-matches regexp line) + ((and m+ (_ _ ...)) + (proc line m+)) + (_ line))))) + line + rx+proc))) + (display line out) + (loop (read-line in 'concat))))))) diff --git a/test/00-sed-case.sh b/test/00-sed-case.sh new file mode 100644 index 0000000..9e78665 --- /dev/null +++ b/test/00-sed-case.sh @@ -0,0 +1 @@ +echo ooO | \sed s,o,O,i diff --git a/test/00-sed-case.stdout b/test/00-sed-case.stdout new file mode 100644 index 0000000..327d153 --- /dev/null +++ b/test/00-sed-case.stdout @@ -0,0 +1 @@ +OoO diff --git a/test/00-sed-global.sh b/test/00-sed-global.sh new file mode 100644 index 0000000..d3f53bd --- /dev/null +++ b/test/00-sed-global.sh @@ -0,0 +1 @@ +echo 001 | \sed s,0,1,g diff --git a/test/00-sed-global.stdout b/test/00-sed-global.stdout new file mode 100644 index 0000000..58c9bdf --- /dev/null +++ b/test/00-sed-global.stdout @@ -0,0 +1 @@ +111 diff --git a/test/00-sed-group-extended.sh b/test/00-sed-group-extended.sh new file mode 100644 index 0000000..ece581c --- /dev/null +++ b/test/00-sed-group-extended.sh @@ -0,0 +1 @@ +echo 012 | \sed -r 's,(0)1(2),\21\1,' diff --git a/test/00-sed-group-extended.stdout b/test/00-sed-group-extended.stdout new file mode 100644 index 0000000..cd7da05 --- /dev/null +++ b/test/00-sed-group-extended.stdout @@ -0,0 +1 @@ +210 diff --git a/test/00-sed-group.sh b/test/00-sed-group.sh new file mode 100644 index 0000000..f5bff3e --- /dev/null +++ b/test/00-sed-group.sh @@ -0,0 +1 @@ +echo 012 | \sed 's,\(0\)1\(2\),\21\1,' diff --git a/test/00-sed-group.stdout b/test/00-sed-group.stdout new file mode 100644 index 0000000..cd7da05 --- /dev/null +++ b/test/00-sed-group.stdout @@ -0,0 +1 @@ +210 diff --git a/test/00-sed-once.sh b/test/00-sed-once.sh new file mode 100644 index 0000000..f133d0e --- /dev/null +++ b/test/00-sed-once.sh @@ -0,0 +1 @@ +echo 001 | \sed s,0,1, diff --git a/test/00-sed-once.stdout b/test/00-sed-once.stdout new file mode 100644 index 0000000..398050c --- /dev/null +++ b/test/00-sed-once.stdout @@ -0,0 +1 @@ +101 diff --git a/test/00-sed-twice.sh b/test/00-sed-twice.sh new file mode 100644 index 0000000..fe13896 --- /dev/null +++ b/test/00-sed-twice.sh @@ -0,0 +1 @@ +echo 0001 | \sed -e s,0,1, -e s,0,1, diff --git a/test/00-sed-twice.stdout b/test/00-sed-twice.stdout new file mode 100644 index 0000000..4f1e6aa --- /dev/null +++ b/test/00-sed-twice.stdout @@ -0,0 +1 @@ +1101 diff --git a/test/00-sed-undo.sh b/test/00-sed-undo.sh new file mode 100644 index 0000000..cd50810 --- /dev/null +++ b/test/00-sed-undo.sh @@ -0,0 +1 @@ +echo 001 | \sed -e s,0,1, -e s,1,0, diff --git a/test/00-sed-undo.stdout b/test/00-sed-undo.stdout new file mode 100644 index 0000000..5325a8d --- /dev/null +++ b/test/00-sed-undo.stdout @@ -0,0 +1 @@ +001 diff --git a/test/00-sed.sh b/test/00-sed.sh new file mode 100644 index 0000000..50f862c --- /dev/null +++ b/test/00-sed.sh @@ -0,0 +1 @@ +\sed --help diff --git a/test/00-sed.stdout b/test/00-sed.stdout new file mode 100644 index 0000000..b041df2 --- /dev/null +++ b/test/00-sed.stdout @@ -0,0 +1,7 @@ +Usage: sed [OPTION]... [SCRIPT] [FILE]... + -e, --expression=SCRIPT add SCRIPT to the commands to be executed + -E, -r, --regexp-extended use extended regular expressions in the script + -f, --file=SCRIPT add contents of SCRIPT to the commands to be executed + -h, --help display this help + -i, --in-place edit files in place + -V, --version display version From d626cdb13610db2f0c36e3acd89c2d7334aae9e9 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 31 Oct 2018 19:53:33 +0100 Subject: [PATCH 184/312] build: Fixes. * build-aux/trace.sh: Import from Mes. * build-aux/build-guile.sh: Update from Mes. * makefile: Avoid endless reconfigure. --- build-aux/build-guile.sh | 142 ++++++++++++++++++++------------------- build-aux/trace.sh | 41 +++++++++++ makefile | 9 ++- 3 files changed, 119 insertions(+), 73 deletions(-) create mode 100644 build-aux/trace.sh diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 50533d7..dae985e 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -10,28 +10,19 @@ # the Free Software Foundation; either version 3 of the License, or (at # your option) any later version. # -# Gash is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. +# Gash is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. # # You should have received a copy of the GNU General Public License # along with Gash. If not, see . -if [ -n "$BUILD_DEBUG" ]; then - set -x -fi +srcdir=${srcdir-.} +. ${srcdest}build-aux/trace.sh export GUILE export GUILE_AUTO_COMPILE -export GUILE_LOAD_PATH -export GUILE_LOAD_COMPILED_PATH - -GUILE_LOAD_PATH=$HOME/src/geesh:$GUILE_LOAD_PATH -GUILE_LOAD_COMPILED_PATH=$HOME/src/geesh:$GUILE_LOAD_COMPILED_PATH - -GUILE_LOAD_PATH=$(pwd):$GUILE_LOAD_PATH -GUILE_LOAD_COMPILED_PATH=$(pwd):$GUILE_LOAD_COMPILED_PATH GUILE=${GUILE-$(command -v guile)} GUILE_TOOLS=${GUILE_TOOLS-$(command -v guile-tools)} GUILE_AUTO_COMPILE=0 @@ -39,68 +30,79 @@ GUILE_AUTO_COMPILE=0 set -e SCM_FILES=" -gash/bournish-commands.scm -gash/guix-utils.scm -gash/builtins.scm -gash/compress.scm -gash/config.scm -gash/environment.scm -gash/geesh.scm -gash/gash.scm -gash/io.scm -gash/job.scm -gash/lzw.scm -gash/peg.scm -gash/pipe.scm -gash/readline.scm -gash/script.scm -gash/shell-utils.scm -gash/ustar.scm -gash/util.scm +${srcdest}gash/bournish-commands.scm +${srcdest}gash/guix-utils.scm +${srcdest}gash/builtins.scm +${srcdest}gash/compress.scm +${srcdest}gash/config.scm +${srcdest}gash/environment.scm +${srcdest}gash/geesh.scm +${srcdest}gash/gash.scm +${srcdest}gash/io.scm +${srcdest}gash/job.scm +${srcdest}gash/lzw.scm +${srcdest}gash/peg.scm +${srcdest}gash/pipe.scm +${srcdest}gash/readline.scm +${srcdest}gash/script.scm +${srcdest}gash/shell-utils.scm +${srcdest}gash/ustar.scm +${srcdest}gash/util.scm + +${srcdest}gash/commands/cat.scm +${srcdest}gash/commands/compress.scm +${srcdest}gash/commands/cp.scm +${srcdest}gash/commands/find.scm +${srcdest}gash/commands/grep.scm +${srcdest}gash/commands/ls.scm +${srcdest}gash/commands/reboot.scm +${srcdest}gash/commands/rm.scm +${srcdest}gash/commands/sed.scm +${srcdest}gash/commands/tar.scm +${srcdest}gash/commands/wc.scm +${srcdest}gash/commands/which.scm -gash/commands/cat.scm -gash/commands/compress.scm -gash/commands/cp.scm -gash/commands/find.scm -gash/commands/grep.scm -gash/commands/ls.scm -gash/commands/reboot.scm -gash/commands/sed.scm -gash/commands/tar.scm -gash/commands/wc.scm -gash/commands/which.scm " -export srcdir=. -export host=$($GUILE -c "(display %host-type)") - -for i in $SCM_FILES; do - go=${i%%.scm}.go - if [ $i -nt $go ]; then - echo " GUILEC $i" - $GUILE_TOOLS compile -L bin -L gash -o $go $i - fi -done - SCRIPTS=" -bin/cat -bin/compress -bin/cp -bin/find -bin/gash -bin/grep -bin/ls -bin/reboot -bin/sed -bin/tar -bin/wc -bin/which +${srcdest}bin/cat +${srcdest}bin/compress +${srcdest}bin/cp +${srcdest}bin/find +${srcdest}bin/gash +${srcdest}bin/grep +${srcdest}bin/ls +${srcdest}bin/reboot +${srcdest}bin/sed +${srcdest}bin/tar +${srcdest}bin/wc +${srcdest}bin/which " -for i in $SCRIPTS; do +export host=$($GUILE -c "(display %host-type)") + +abs=$srcdest +if [ "$GUILE_EFFECTIVE_VERSION" = "2.0" ]; then + srcdest=$abs_top_srcdir/ +fi + +GUILE_AUTO_COMPILE=0 +WARNINGS=" +--warn=unsupported-warning +--warn=unused-variable +--warn=unused-toplevel +--warn=unbound-variable +--warn=macro-use-before-definition +--warn=arity-mismatch +--warn=duplicate-case-datum +--warn=bad-case-datum +--warn=format +" + +for i in $SCM_FILES $SCRIPTS; do + b=$(basename $i) go=${i%%.scm}.go if [ $i -nt $go ]; then - echo " GUILEC $i" - $GUILE_TOOLS compile -L guile -L scripts -o $go $i + trace "GUILEC $b" $GUILE_TOOLS compile -L ${srcdir} $WARNINGS -o $go $i fi done diff --git a/build-aux/trace.sh b/build-aux/trace.sh new file mode 100644 index 0000000..6f5d0ef --- /dev/null +++ b/build-aux/trace.sh @@ -0,0 +1,41 @@ +# Gash --- Guile As SHell +# Copyright © 2018 Jan (janneke) Nieuwenhuizen +# +# This file is part of Gash. +# +# Gash is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or (at +# your option) any later version. +# +# Gash is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License +# along with Gash. If not, see . + +if [ -z "$V" -o "$V0" = 0 ]; then + trace () { + echo " $1" + shift + eval "$@" $LOG + } + LOG=" >>build.log 2>&1" +fi +if [ "$V" = 1 ]; then + trace () { + shift + echo "$@" + eval "$@ $LOG" + } + LOG=" >>build.log 2>&1" +fi +if [ "$V" = 2 ]; then + set -x + trace () { + shift + eval "$@" + } +fi diff --git a/makefile b/makefile index 62a7df9..2854861 100644 --- a/makefile +++ b/makefile @@ -5,15 +5,18 @@ default: all .config.make: makefile -bin/gash: bin/gash.in | do-configure -bin/tar: bin/tar.in | do-configure +bin/gash: bin/gash.in + $(MAKE) do-configure + +gash/config.scm: + $(MAKE) do-configure do-configure: ./configure --prefix=$(prefix) all: all-go -all-go: | do-configure +all-go: | gash/config.scm build-aux/build-guile.sh clean: From 1f9480cda166e52eb8e10582f1b565dcc6427bfe Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 31 Oct 2018 20:34:48 +0100 Subject: [PATCH 185/312] Guile As SHell. --- build-aux/pre-inst-env.in | 2 +- gash/bournish-commands.scm | 2 +- gash/builtins.scm | 2 +- gash/commands/cat.scm | 2 +- gash/commands/compress.scm | 2 +- gash/commands/cp.scm | 2 +- gash/commands/find.scm | 2 +- gash/commands/grep.scm | 2 +- gash/commands/ls.scm | 2 +- gash/commands/reboot.scm | 2 +- gash/commands/sed.scm | 2 +- gash/commands/tar.scm | 2 +- gash/commands/wc.scm | 2 +- gash/commands/which.scm | 2 +- gash/config.scm.in | 2 +- gash/environment.scm | 2 +- gash/geesh.scm | 2 +- gash/guix-utils.scm | 2 +- gash/readline.scm | 2 +- gash/script.scm | 2 +- gash/shell-utils.scm | 2 +- 21 files changed, 21 insertions(+), 21 deletions(-) diff --git a/build-aux/pre-inst-env.in b/build-aux/pre-inst-env.in index 0f45566..2e47e54 100644 --- a/build-aux/pre-inst-env.in +++ b/build-aux/pre-inst-env.in @@ -1,6 +1,6 @@ #! @BASH@ -# Gash -- Guile As SHell +# Gash --- Guile As SHell # Copyright © 2018 Jan (janneke) Nieuwenhuizen # # This file is part of Gash. diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 9191ce6..6ebe234 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2016, 2017 Ludovic Courtès ;;; Copyright © 2016 Efraim Flashner ;;; Copyright © 2017 Ricardo Wurmus diff --git a/gash/builtins.scm b/gash/builtins.scm index 944884d..ddded24 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Gash. diff --git a/gash/commands/cat.scm b/gash/commands/cat.scm index 3af3f6b..dd1ad18 100644 --- a/gash/commands/cat.scm +++ b/gash/commands/cat.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2016, 2017 Ludovic Courtès ;;; Copyright © 2016 Efraim Flashner ;;; Copyright © 2017 Ricardo Wurmus diff --git a/gash/commands/compress.scm b/gash/commands/compress.scm index bfce7f0..5abf055 100644 --- a/gash/commands/compress.scm +++ b/gash/commands/compress.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Gash. diff --git a/gash/commands/cp.scm b/gash/commands/cp.scm index 4e486ae..62baee6 100644 --- a/gash/commands/cp.scm +++ b/gash/commands/cp.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2016, 2017 Ludovic Courtès ;;; Copyright © 2016 Efraim Flashner ;;; Copyright © 2017 Ricardo Wurmus diff --git a/gash/commands/find.scm b/gash/commands/find.scm index 19bc5a3..e3abb4a 100644 --- a/gash/commands/find.scm +++ b/gash/commands/find.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2016, 2017 Ludovic Courtès ;;; Copyright © 2016 Efraim Flashner ;;; Copyright © 2017 Ricardo Wurmus diff --git a/gash/commands/grep.scm b/gash/commands/grep.scm index c310d21..bc0aba5 100644 --- a/gash/commands/grep.scm +++ b/gash/commands/grep.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Gash. diff --git a/gash/commands/ls.scm b/gash/commands/ls.scm index c15e5e4..d7e2e03 100644 --- a/gash/commands/ls.scm +++ b/gash/commands/ls.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2016, 2017 Ludovic Courtès ;;; Copyright © 2016 Efraim Flashner ;;; Copyright © 2017 Ricardo Wurmus diff --git a/gash/commands/reboot.scm b/gash/commands/reboot.scm index ae6a9da..490fe28 100644 --- a/gash/commands/reboot.scm +++ b/gash/commands/reboot.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2016, 2017 Ludovic Courtès ;;; Copyright © 2016 Efraim Flashner ;;; Copyright © 2017 Ricardo Wurmus diff --git a/gash/commands/sed.scm b/gash/commands/sed.scm index 5f3f7d5..d8f8f94 100644 --- a/gash/commands/sed.scm +++ b/gash/commands/sed.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Gash. diff --git a/gash/commands/tar.scm b/gash/commands/tar.scm index 32449ec..251c693 100644 --- a/gash/commands/tar.scm +++ b/gash/commands/tar.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Gash. diff --git a/gash/commands/wc.scm b/gash/commands/wc.scm index 8d4c386..3ca7f91 100644 --- a/gash/commands/wc.scm +++ b/gash/commands/wc.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2016, 2017 Ludovic Courtès ;;; Copyright © 2016 Efraim Flashner ;;; Copyright © 2017 Ricardo Wurmus diff --git a/gash/commands/which.scm b/gash/commands/which.scm index a4fa981..cc0f49a 100644 --- a/gash/commands/which.scm +++ b/gash/commands/which.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2016, 2017 Ludovic Courtès ;;; Copyright © 2016 Efraim Flashner ;;; Copyright © 2017 Ricardo Wurmus diff --git a/gash/config.scm.in b/gash/config.scm.in index 0d7ec41..8cb16da 100644 --- a/gash/config.scm.in +++ b/gash/config.scm.in @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Gash. diff --git a/gash/environment.scm b/gash/environment.scm index 81de2ba..5569d44 100644 --- a/gash/environment.scm +++ b/gash/environment.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2018 R.E.W. van Beusekom ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; diff --git a/gash/geesh.scm b/gash/geesh.scm index db7546a..c9f5fce 100644 --- a/gash/geesh.scm +++ b/gash/geesh.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Gash. diff --git a/gash/guix-utils.scm b/gash/guix-utils.scm index 285f627..f347b5b 100644 --- a/gash/guix-utils.scm +++ b/gash/guix-utils.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2013, 2014, 2015 Mark H Weaver ;;; Copyright © 2014 Eric Bavier diff --git a/gash/readline.scm b/gash/readline.scm index 3b4d960..df6aecc 100644 --- a/gash/readline.scm +++ b/gash/readline.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Gash. diff --git a/gash/script.scm b/gash/script.scm index e046fd5..fbd5bc9 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Gash. diff --git a/gash/shell-utils.scm b/gash/shell-utils.scm index e115a17..34e12d1 100644 --- a/gash/shell-utils.scm +++ b/gash/shell-utils.scm @@ -1,4 +1,4 @@ -;;; Gash -- Guile As SHell +;;; Gash --- Guile As SHell ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov From 6203f8cf07802d7db0217073390b1299f2b12018 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 31 Oct 2018 20:22:13 +0100 Subject: [PATCH 186/312] test: Update test suite. --- check.sh | 10 ++++++---- gash/script.scm | 4 +--- test.sh | 2 +- ...t-double-quote.sh => 05-assignment-double-quote.sh} | 0 test/05-assignment-doublequoted-doublequotes.stdout | 1 + test/{06-assignment-echo.sh => 05-assignment-echo.sh} | 0 test/05-assignment-empty.sh | 2 ++ test/05-assignment-empty.stdout | 1 + ...ent-singlequote.sh => 05-assignment-singlequote.sh} | 0 ...variable-word.sh => 05-assignment-variable-word.sh} | 0 test/09-compound-word.stdout | 1 + test/0a-assign-substitute.sh | 1 + test/0a-assign-substitute.stdout | 1 + test/0b-command-compound-word.stdout | 1 + test/32-for-substitute.stdout | 2 ++ test/data/star/0 | 0 test/data/star/1 | 0 test/data/star/2 | 0 test/data/star/3 | 0 test/for-split-sequence.sh | 3 +-- test/for-split-sequence.stdout | 6 ++++++ test/iohere.stdout | 1 + test/nesting.stdout | 1 + test/pipe-3.sh | 1 + test/pipe-3.stdout | 7 +++++++ test/pipe.sh | 2 +- test/pipe.stdout | 7 +++++++ 27 files changed, 43 insertions(+), 11 deletions(-) rename test/{07-assignment-double-quote.sh => 05-assignment-double-quote.sh} (100%) create mode 100644 test/05-assignment-doublequoted-doublequotes.stdout rename test/{06-assignment-echo.sh => 05-assignment-echo.sh} (100%) create mode 100644 test/05-assignment-empty.sh create mode 100644 test/05-assignment-empty.stdout rename test/{06-assignment-singlequote.sh => 05-assignment-singlequote.sh} (100%) rename test/{08-assignment-variable-word.sh => 05-assignment-variable-word.sh} (100%) create mode 100644 test/09-compound-word.stdout create mode 100644 test/0a-assign-substitute.stdout create mode 100644 test/0b-command-compound-word.stdout create mode 100644 test/32-for-substitute.stdout create mode 100644 test/data/star/0 create mode 100644 test/data/star/1 create mode 100644 test/data/star/2 create mode 100644 test/data/star/3 create mode 100644 test/for-split-sequence.stdout create mode 100644 test/iohere.stdout create mode 100644 test/nesting.stdout create mode 100644 test/pipe-3.sh create mode 100644 test/pipe-3.stdout create mode 100644 test/pipe.stdout diff --git a/check.sh b/check.sh index 6a1679a..59071fb 100755 --- a/check.sh +++ b/check.sh @@ -16,6 +16,7 @@ list ls nesting pipe +pipe-3 substitution 00-exit 01-exit-0 @@ -24,10 +25,11 @@ substitution 04-echo-var 05-assignment-doublequoted-doublequotes 05-assignment -06-assignment-echo -06-assignment-singlequote -07-assignment-double-quote -08-assignment-variable-word +05-assignment-empty +05-assignment-echo +05-assignment-singlequote +05-assignment-double-quote +05-assignment-variable-word 09-compound-word 0a-assign-substitute 0b-command-compound-word diff --git a/gash/script.scm b/gash/script.scm index fbd5bc9..44a951c 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -77,7 +77,7 @@ (command (cons program (cdr command)))) (or (builtin command #:prefer-builtin? (or %prefer-builtins? escape-builtin?)) - (cut apply (compose status:exit-val system*) command)))) + (lambda _ (status:exit-val (apply system* command)))))) (else (lambda () #t)))) (exec (append-map glob args))) @@ -118,9 +118,7 @@ (string-join (append-map glob o) "")) (define (sequence . args) - (format (current-error-port) "sequence args=~s\n" args) (let ((glob (append-map glob (apply append args)))) - (format (current-error-port) " => sequence glob=~s\n" glob) glob)) (define (run ast) diff --git a/test.sh b/test.sh index babfbe9..3a0f097 100755 --- a/test.sh +++ b/test.sh @@ -8,7 +8,7 @@ SHELL=${SHELL-bin/gash} t=$1 b=test/$(basename $t .sh) set +e -$SHELL -e $b.sh > $b.1 2> $b.2 +timeout 1 $SHELL -e $b.sh > $b.1 2> $b.2 r=$? set -e if [ -f $b.exit ]; then diff --git a/test/07-assignment-double-quote.sh b/test/05-assignment-double-quote.sh similarity index 100% rename from test/07-assignment-double-quote.sh rename to test/05-assignment-double-quote.sh diff --git a/test/05-assignment-doublequoted-doublequotes.stdout b/test/05-assignment-doublequoted-doublequotes.stdout new file mode 100644 index 0000000..5380254 --- /dev/null +++ b/test/05-assignment-doublequoted-doublequotes.stdout @@ -0,0 +1 @@ +cc -DALIASPATH="alias" -DLOCALEDIR="x" diff --git a/test/06-assignment-echo.sh b/test/05-assignment-echo.sh similarity index 100% rename from test/06-assignment-echo.sh rename to test/05-assignment-echo.sh diff --git a/test/05-assignment-empty.sh b/test/05-assignment-empty.sh new file mode 100644 index 0000000..6aba02a --- /dev/null +++ b/test/05-assignment-empty.sh @@ -0,0 +1,2 @@ +a= +echo a=$a diff --git a/test/05-assignment-empty.stdout b/test/05-assignment-empty.stdout new file mode 100644 index 0000000..2afe6dc --- /dev/null +++ b/test/05-assignment-empty.stdout @@ -0,0 +1 @@ +a= diff --git a/test/06-assignment-singlequote.sh b/test/05-assignment-singlequote.sh similarity index 100% rename from test/06-assignment-singlequote.sh rename to test/05-assignment-singlequote.sh diff --git a/test/08-assignment-variable-word.sh b/test/05-assignment-variable-word.sh similarity index 100% rename from test/08-assignment-variable-word.sh rename to test/05-assignment-variable-word.sh diff --git a/test/09-compound-word.stdout b/test/09-compound-word.stdout new file mode 100644 index 0000000..81f5a26 --- /dev/null +++ b/test/09-compound-word.stdout @@ -0,0 +1 @@ +cc -c ./ diff --git a/test/0a-assign-substitute.sh b/test/0a-assign-substitute.sh index 91b1091..51c6bf6 100644 --- a/test/0a-assign-substitute.sh +++ b/test/0a-assign-substitute.sh @@ -1,2 +1,3 @@ obj=ar.o objs="$objs `basename $obj`" +echo "objs:>$objs<" diff --git a/test/0a-assign-substitute.stdout b/test/0a-assign-substitute.stdout new file mode 100644 index 0000000..2cde7c4 --- /dev/null +++ b/test/0a-assign-substitute.stdout @@ -0,0 +1 @@ +objs:> ar.o< diff --git a/test/0b-command-compound-word.stdout b/test/0b-command-compound-word.stdout new file mode 100644 index 0000000..366e732 --- /dev/null +++ b/test/0b-command-compound-word.stdout @@ -0,0 +1 @@ +-I ar.o diff --git a/test/32-for-substitute.stdout b/test/32-for-substitute.stdout new file mode 100644 index 0000000..ec37551 --- /dev/null +++ b/test/32-for-substitute.stdout @@ -0,0 +1,2 @@ +compiling ar.o... +compiling arscan.o... diff --git a/test/data/star/0 b/test/data/star/0 new file mode 100644 index 0000000..e69de29 diff --git a/test/data/star/1 b/test/data/star/1 new file mode 100644 index 0000000..e69de29 diff --git a/test/data/star/2 b/test/data/star/2 new file mode 100644 index 0000000..e69de29 diff --git a/test/data/star/3 b/test/data/star/3 new file mode 100644 index 0000000..e69de29 diff --git a/test/for-split-sequence.sh b/test/for-split-sequence.sh index 4716fe7..1ef55e4 100644 --- a/test/for-split-sequence.sh +++ b/test/for-split-sequence.sh @@ -1,5 +1,4 @@ one=1 -two_n_halve= -for i in 0 $one 2 $two_n_halve 3 ""; do +for i in 0 $one 2 $two_n_halve $two_n_quaaar and 3 ""; do echo $i; done diff --git a/test/for-split-sequence.stdout b/test/for-split-sequence.stdout new file mode 100644 index 0000000..b1fc8b4 --- /dev/null +++ b/test/for-split-sequence.stdout @@ -0,0 +1,6 @@ +0 +1 +2 +and +3 + diff --git a/test/iohere.stdout b/test/iohere.stdout new file mode 100644 index 0000000..323fae0 --- /dev/null +++ b/test/iohere.stdout @@ -0,0 +1 @@ +foobar diff --git a/test/nesting.stdout b/test/nesting.stdout new file mode 100644 index 0000000..5635c74 --- /dev/null +++ b/test/nesting.stdout @@ -0,0 +1 @@ +foo "bar" diff --git a/test/pipe-3.sh b/test/pipe-3.sh new file mode 100644 index 0000000..0c1fb4a --- /dev/null +++ b/test/pipe-3.sh @@ -0,0 +1 @@ +echo -e 'a\nb\nc' test/data/star/* | sed 's, ,\n,g' | cat diff --git a/test/pipe-3.stdout b/test/pipe-3.stdout new file mode 100644 index 0000000..36c2abd --- /dev/null +++ b/test/pipe-3.stdout @@ -0,0 +1,7 @@ +a +b +c +test/data/star/0 +test/data/star/1 +test/data/star/2 +test/data/star/3 diff --git a/test/pipe.sh b/test/pipe.sh index 9055090..5fb2d9e 100644 --- a/test/pipe.sh +++ b/test/pipe.sh @@ -1 +1 @@ -echo -e 'a\nb\nc' * | sed 's, ,\n,g' | cat +echo -e 'a\nb\nc' test/data/star/* | \sed 's, ,\n,g' diff --git a/test/pipe.stdout b/test/pipe.stdout new file mode 100644 index 0000000..36c2abd --- /dev/null +++ b/test/pipe.stdout @@ -0,0 +1,7 @@ +a +b +c +test/data/star/0 +test/data/star/1 +test/data/star/2 +test/data/star/3 From ab4ce3b99562784ab46d84ff620a1c02e4a2e0a7 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 31 Oct 2018 20:43:15 +0100 Subject: [PATCH 187/312] test: Add check-geesh. --- gash/geesh.scm | 5 +++-- makefile | 3 +++ 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/gash/geesh.scm b/gash/geesh.scm index c9f5fce..b5796b1 100644 --- a/gash/geesh.scm +++ b/gash/geesh.scm @@ -37,8 +37,9 @@ (format (current-error-port) "parse-tree:\n") (pretty-print parse-tree (current-error-port))) (let ((ast (parse-tree->script parse-tree))) + (when (> %debug-level 1) (format (current-error-port) "transformed:\n") - (pretty-print ast (current-error-port)) + (pretty-print ast (current-error-port))) (let* ((script (match ast (((or 'command 'pipeline) _ ...) `(script ,ast)) ((_ ...) `(script ,@ast)) @@ -86,7 +87,7 @@ ((' cmd) `(substitution ,(transform cmd))) ((' (expression then)) `(if-clause ,(transform expression) ,(transform then))) ((' (('<< 0 string)) pipeline) - (let ((pipeline (pke 'pipeline (transform pipeline)))) + (let ((pipeline (transform pipeline))) `(pipeline (display ,(transform string)) ,@(match pipeline (('command command ...) `(,pipeline)) diff --git a/makefile b/makefile index 2854861..2f1aaa6 100644 --- a/makefile +++ b/makefile @@ -35,6 +35,9 @@ endif check-gash: all SHELL=bin/gash ./check.sh +check-geesh: all + SHELL='bin/gash --geesh' ./check.sh + install: all mkdir -p $(DESTDIR)$(bindir) cp bin/gash $(DESTDIR)$(bindir)/gash From 6224bbeefc44dc7e7763a6287ee1110ca0573c70 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 31 Oct 2018 21:44:31 +0100 Subject: [PATCH 188/312] test: tar. --- check.sh | 5 +++++ gash/commands/tar.scm | 9 +++++---- gash/ustar.scm | 17 ++++++++++------- makefile | 2 +- test/00-tar-Z-old.sh | 2 ++ test/00-tar-Z-old.stdout | 5 +++++ test/00-tar-Z-pipe.sh | 1 + test/00-tar-Z-pipe.stdout | 5 +++++ test/00-tar-Z.sh | 3 +++ test/00-tar-Z.stdout | 5 +++++ test/00-tar.sh | 1 + test/00-tar.stdout | 5 +++++ test/data/star/0 | 1 + test/data/star/1 | 1 + test/data/star/2 | 1 + test/data/star/3 | 1 + 16 files changed, 52 insertions(+), 12 deletions(-) create mode 100644 test/00-tar-Z-old.sh create mode 100644 test/00-tar-Z-old.stdout create mode 100644 test/00-tar-Z-pipe.sh create mode 100644 test/00-tar-Z-pipe.stdout create mode 100644 test/00-tar-Z.sh create mode 100644 test/00-tar-Z.stdout create mode 100644 test/00-tar.sh create mode 100644 test/00-tar.stdout diff --git a/check.sh b/check.sh index 59071fb..c6e5c5c 100755 --- a/check.sh +++ b/check.sh @@ -53,6 +53,11 @@ substitution 00-sed-group-extended 00-sed-twice 00-sed-undo + +00-tar +00-tar-Z +00-tar-Z-old +00-tar-Z-pipe " broken=" diff --git a/gash/commands/tar.scm b/gash/commands/tar.scm index 251c693..8a1a3d7 100644 --- a/gash/commands/tar.scm +++ b/gash/commands/tar.scm @@ -80,6 +80,7 @@ ((string-suffix? ".gz" file) 'gzip) ((string-suffix? ".xz" file) 'xz) (else #f)))))) + (sort-order (and=> (option-ref options 'sort #f) string->symbol)) (help? (option-ref options 'help #f)) (usage? (and (not help?) (not (or (and create? (pair? files)) extract? list?)))) @@ -107,8 +108,8 @@ Usage: tar [OPTION]... [FILE]... ") (exit (if usage? 2 0))) (create? - (let ((files (if (not (option-ref options 'sort #f)) files - (sort files string<))) + (let ((files (if (eq? sort-order 'name) (sort files string<) + files)) (group (and=> (option-ref options 'group #f) string->number)) (mtime (and=> (option-ref options 'mtime #f) string->number)) (numeric-owner? (option-ref options 'numeric-owner? #f)) @@ -123,7 +124,7 @@ Usage: tar [OPTION]... [FILE]... ,@(if mtime `(#:mtime ,mtime) '()) ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) ,@(if owner `(#:owner ,owner) '()) - ,@(if owner `(#:owner ,owner) '()) + ,@(if sort-order `(#:sort-order ,sort-order) '()) #:verbosity ,verbosity)))) (apply write-ustar-archive `(,file @@ -132,7 +133,7 @@ Usage: tar [OPTION]... [FILE]... ,@(if mtime `(#:mtime ,mtime) '()) ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) ,@(if owner `(#:owner ,owner) '()) - ,@(if owner `(#:owner ,owner) '()) + ,@(if sort-order `(#:sort-order ,sort-order) '()) #:verbosity ,verbosity))))) (extract? (if (or compression (equal? file "-")) diff --git a/gash/ustar.scm b/gash/ustar.scm index 6701c85..2e613bd 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -419,7 +419,7 @@ %uname %gname %dev-major %dev-minor %prefix)))))) -(define* (write-ustar-file port file-name #:key group mtime numeric-owner? owner verbosity) +(define* (write-ustar-file port file-name #:key group mtime numeric-owner? owner sort-order verbosity) (let* ((file-name (if (string-every file-name-separator? file-name) file-name-separator-string (string-trim-right file-name file-name-separator?))) @@ -446,9 +446,12 @@ (write-ustar-record port buf 0 obtained) (loop (- left obtained))))))))) ((directory) - (for-each (lambda (file-name) (write-ustar-file port file-name - #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity)) - (files-in-directory file-name)))))) + (let* ((files (files-in-directory file-name)) + (files (if (eq? sort-order 'name) (sort files string<) + files))) + (for-each (lambda (file-name) (write-ustar-file port file-name + #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity)) + files)))))) (define (ustar-header-file-name header) (let ((name (ustar-header-name header)) @@ -504,10 +507,10 @@ (display file-name)) (newline))) -(define* (write-ustar-port out files #:key group mtime numeric-owner? owner verbosity) +(define* (write-ustar-port out files #:key group mtime numeric-owner? owner sort-order verbosity) (for-each (cut write-ustar-file out <> - #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity) + #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:sort-order sort-order #:verbosity verbosity) files)) (define* (write-ustar-archive file-name files #:key group mtime numeric-owner? owner verbosity) @@ -515,7 +518,7 @@ (lambda _ (call-with-port* (open-file file-name "wb") (cut write-ustar-port <> files - #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity))) + #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:sort-order sort-order #:verbosity verbosity))) (lambda (key subr message args . rest) (false-if-exception (delete-file file-name)) (format (current-error-port) "ERROR: ~a\n" diff --git a/makefile b/makefile index 2f1aaa6..b51e361 100644 --- a/makefile +++ b/makefile @@ -29,7 +29,7 @@ check: all check-bash check-gash check-bash: all ifneq ($(BASH),) - SHELL=$(BASH) ./check.sh + PATH=$(PATH):bin SHELL=$(BASH) ./check.sh endif check-gash: all diff --git a/test/00-tar-Z-old.sh b/test/00-tar-Z-old.sh new file mode 100644 index 0000000..ba72f78 --- /dev/null +++ b/test/00-tar-Z-old.sh @@ -0,0 +1,2 @@ +\tar cZf tmp.tar --sort=name test/data/star +\tar tZf tmp.tar diff --git a/test/00-tar-Z-old.stdout b/test/00-tar-Z-old.stdout new file mode 100644 index 0000000..7f14d75 --- /dev/null +++ b/test/00-tar-Z-old.stdout @@ -0,0 +1,5 @@ +test/data/star/ +test/data/star/0 +test/data/star/1 +test/data/star/2 +test/data/star/3 diff --git a/test/00-tar-Z-pipe.sh b/test/00-tar-Z-pipe.sh new file mode 100644 index 0000000..8b308d4 --- /dev/null +++ b/test/00-tar-Z-pipe.sh @@ -0,0 +1 @@ +\tar -cZf- --sort=name test/data/star | \tar -tZf- diff --git a/test/00-tar-Z-pipe.stdout b/test/00-tar-Z-pipe.stdout new file mode 100644 index 0000000..7f14d75 --- /dev/null +++ b/test/00-tar-Z-pipe.stdout @@ -0,0 +1,5 @@ +test/data/star/ +test/data/star/0 +test/data/star/1 +test/data/star/2 +test/data/star/3 diff --git a/test/00-tar-Z.sh b/test/00-tar-Z.sh new file mode 100644 index 0000000..d5c043e --- /dev/null +++ b/test/00-tar-Z.sh @@ -0,0 +1,3 @@ +\tar -cZf tmp.tar --sort=name test/data/star +\tar -tZf tmp.tar + diff --git a/test/00-tar-Z.stdout b/test/00-tar-Z.stdout new file mode 100644 index 0000000..7f14d75 --- /dev/null +++ b/test/00-tar-Z.stdout @@ -0,0 +1,5 @@ +test/data/star/ +test/data/star/0 +test/data/star/1 +test/data/star/2 +test/data/star/3 diff --git a/test/00-tar.sh b/test/00-tar.sh new file mode 100644 index 0000000..445fc3a --- /dev/null +++ b/test/00-tar.sh @@ -0,0 +1 @@ +\tar -cf- --sort=name test/data/star | \tar -tf- diff --git a/test/00-tar.stdout b/test/00-tar.stdout new file mode 100644 index 0000000..7f14d75 --- /dev/null +++ b/test/00-tar.stdout @@ -0,0 +1,5 @@ +test/data/star/ +test/data/star/0 +test/data/star/1 +test/data/star/2 +test/data/star/3 diff --git a/test/data/star/0 b/test/data/star/0 index e69de29..573541a 100644 --- a/test/data/star/0 +++ b/test/data/star/0 @@ -0,0 +1 @@ +0 diff --git a/test/data/star/1 b/test/data/star/1 index e69de29..d00491f 100644 --- a/test/data/star/1 +++ b/test/data/star/1 @@ -0,0 +1 @@ +1 diff --git a/test/data/star/2 b/test/data/star/2 index e69de29..0cfbf08 100644 --- a/test/data/star/2 +++ b/test/data/star/2 @@ -0,0 +1 @@ +2 diff --git a/test/data/star/3 b/test/data/star/3 index e69de29..00750ed 100644 --- a/test/data/star/3 +++ b/test/data/star/3 @@ -0,0 +1 @@ +3 From aafbc96dbd5d1a17a001182d8f725c98c7301f2b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 31 Oct 2018 22:30:49 +0100 Subject: [PATCH 189/312] rm: Resurrect. * gash/commands/rm.scm: Resurrect. * gash/bournish-commands.scm: Add it. * build-aux/build-guile.sh: Compile it. * .gitignore: Ignore it. --- .gitignore | 1 + build-aux/build-guile.sh | 1 + configure | 1 + gash/bournish-commands.scm | 4 +++ gash/commands/rm.scm | 53 ++++++++++++++++++++++++++++++++++++++ 5 files changed, 60 insertions(+) create mode 100644 gash/commands/rm.scm diff --git a/.gitignore b/.gitignore index 7339ac8..b5fabb3 100644 --- a/.gitignore +++ b/.gitignore @@ -9,6 +9,7 @@ /bin/grep /bin/ls /bin/reboot +/bin/rm /bin/sed /bin/sh /bin/tar diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index dae985e..3fe70b0 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -73,6 +73,7 @@ ${srcdest}bin/gash ${srcdest}bin/grep ${srcdest}bin/ls ${srcdest}bin/reboot +${srcdest}bin/rm ${srcdest}bin/sed ${srcdest}bin/tar ${srcdest}bin/wc diff --git a/configure b/configure index b6e7769..93b00c9 100755 --- a/configure +++ b/configure @@ -96,6 +96,7 @@ find grep ls reboot +rm sed tar wc diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 6ebe234..7ceb818 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -38,6 +38,7 @@ #:use-module (gash commands grep) #:use-module (gash commands ls) #:use-module (gash commands reboot) + #:use-module (gash commands rm) #:use-module (gash commands sed) #:use-module (gash commands tar) #:use-module (gash commands wc) @@ -52,6 +53,7 @@ grep-command ls-command reboot-command + rm-command sed-command rm-command wc-command @@ -76,6 +78,7 @@ (define grep-command (wrap-command "grep" grep)) (define ls-command (wrap-command "ls" ls)) (define reboot-command (wrap-command "reboot" reboot)) +(define rm-command (wrap-command "rm" rm)) (define sed-command (wrap-command "sed" sed)) (define tar-command (wrap-command "tar" tar)) (define wc-command (wrap-command "wc" wc)) @@ -90,6 +93,7 @@ ("grep" . ,grep-command) ("ls" . ,ls-command) ("reboot" . ,reboot-command) + ("rm" . ,rm-command) ("sed" . ,sed-command) ("tar" . ,tar-command) ("wc" . ,wc-command) diff --git a/gash/commands/rm.scm b/gash/commands/rm.scm new file mode 100644 index 0000000..0638898 --- /dev/null +++ b/gash/commands/rm.scm @@ -0,0 +1,53 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial bournish.scm was taken from Guix. + +;;; Code: + +(define-module (gash commands rm) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (gash shell-utils) + #:export ( + rm + )) + +(define (rm name . args) + (let ((recursive? (or (member "-r" args) + (member "-fr" args) + (member "-rf" args))) + (force? (or (member "-f" args) + (member "-rf" args) + (member "-fr" args))) + (files (filter (negate (cut string-prefix? "-" <>)) args))) + (catch #t + (lambda _ + (if recursive? (for-each delete-file-recursively files) + (for-each delete-file files)) + #t) + (lambda ( . rest) + (or force? + (apply throw rest)))))) + +(define main rm) From 6175b07c7e79be130761750716334bf8660f9780 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Thu, 1 Nov 2018 07:26:07 +0100 Subject: [PATCH 190/312] pipe: Connect stderr too. * gash/pipe.scm (spawn): Connect stderr too. --- gash/pipe.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/gash/pipe.scm b/gash/pipe.scm index 947b876..0504005 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -72,7 +72,8 @@ (set-current-input-port (car input))) (when (pair? w) (close-port (current-output-port)) - (set-current-output-port (car w))) + (set-current-output-port (car w)) + (set-current-error-port (cadr w))) (let ((status (if (thunk? command) (command) (command input w)))) (exit (cond ((number? status) status) From 992e12444d3bcd1ee26fe8c1e9cf18f16e27d232 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Thu, 1 Nov 2018 08:07:22 +0100 Subject: [PATCH 191/312] chmod: New builtin. * gash/commands/chmod.scm: New file. * build-aux/build-guile.sh: Compile it. * .gitignore: Ignore it. --- .gitignore | 1 + build-aux/build-guile.sh | 2 + configure | 1 + gash/commands/chmod.scm | 168 +++++++++++++++++++++++++++++++++++++++ 4 files changed, 172 insertions(+) create mode 100644 gash/commands/chmod.scm diff --git a/.gitignore b/.gitignore index b5fabb3..eb2068c 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ *~ /bin/bash /bin/cat +/bin/chmod /bin/compress /bin/cp /bin/find diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 3fe70b0..ba68bad 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -50,6 +50,7 @@ ${srcdest}gash/ustar.scm ${srcdest}gash/util.scm ${srcdest}gash/commands/cat.scm +${srcdest}gash/commands/chmod.scm ${srcdest}gash/commands/compress.scm ${srcdest}gash/commands/cp.scm ${srcdest}gash/commands/find.scm @@ -66,6 +67,7 @@ ${srcdest}gash/commands/which.scm SCRIPTS=" ${srcdest}bin/cat +${srcdest}bin/chmod ${srcdest}bin/compress ${srcdest}bin/cp ${srcdest}bin/find diff --git a/configure b/configure index 93b00c9..ba601be 100755 --- a/configure +++ b/configure @@ -90,6 +90,7 @@ sh " BUILTINS=" cat +chmod compress cp find diff --git a/gash/commands/chmod.scm b/gash/commands/chmod.scm new file mode 100644 index 0000000..c028a8e --- /dev/null +++ b/gash/commands/chmod.scm @@ -0,0 +1,168 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; Code: + +(define-module (gash commands chmod) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 regex) + + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) + + #:use-module (gash config) + #:use-module (gash guix-utils) + #:use-module (gash shell-utils) + + #:export ( + chmod + )) + +(define-immutable-record-type + (make-chmodifier users operation permissions) + chmodifier? + (users chmodifier-users) + (operation chmodifier-operation) + (permissions chmodifier-permissions)) + +(define (parse-modifier o) + (let* ((c (string->symbol (substring o 0 1))) + (o (if (memq c '(- + =)) (string-append "a" o) o)) + (users (string->symbol (substring o 0 1)))) + (when (not (memq users '(u g o a))) + (error (format #f "chmod: no such user: ~a" users))) + (let ((operation (string->symbol (substring o 1 2)))) + (when (not (memq operation '(- + =))) + (error (format #f "chmod: no such operation: ~a" operation))) + (let* ((perm-string (substring o 2)) + (perm (string->number perm-string 8))) + (if perm (make-numeric-chmodifier perm) + (let ((perms (map char->symbol (string->list perm-string)))) + (make-chmodifier users operation perms))))))) + +(define (char->symbol c) + (string->symbol (make-string 1 c))) + +(define (parse-modifiers o) + (or (and=> (string->number o 8) (compose list (cut make-numeric-chmodifier <>))) + (map parse-modifier (string-split o #\,)))) + +(define (make-numeric-chmodifier o) + (make-chmodifier 'o '= (list o))) + +(define (apply-chmodifiers file modifiers) + (let* ((mode (stat:mode (lstat file))) + (executable? (if (zero? (logand mode #o111)) 0 1))) + (let loop ((modifiers modifiers) (mode mode)) + (if (null? modifiers) ((@ (guile) chmod) file mode) + (loop (cdr modifiers) + (let* ((m (car modifiers)) + (n (chmodifier-numeric-mode m executable?)) + (o (chmodifier-operation m))) + (case o + ((=) n) + ((+) (logior mode n)) + ((-) (logand mode n)) + (else (error (format #f + "chmod: operation not supported: ~s\n" o)))))))))) + +(define (chmodifier-numeric-mode o executable?) + (let* ((permissions (chmodifier-permissions o)) + (users (chmodifier-users o))) + (let loop ((permissions permissions)) + (if (null? permissions) 0 + (+ (let* ((p (car permissions)) + (base (cond ((number? p) p) + ((symbol? p) + (case p + ((r) 4) + ((w) 2) + ((x) 1) + ((X) executable?)))))) + (case users + ((a) (+ base (ash base 3) (ash base 6))) + ((o) base) + ((g) (ash base 3)) + ((u) (ash base 6)))) + (loop (cdr permissions))))))) + +(define (chmod . args) + (let* ((option-spec + '((reference (value #t)) + (recursive (single-char #\R)) + (help (single-char #\h)) + (version (single-char #\V)) + (writable (single-char #\w)) + (readable (single-char #\r)) + (executable (single-char #\x)) + (xecutable (single-char #\X)))) + (options (getopt-long args option-spec)) + (files (option-ref options '() '())) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '())) + (reference (option-ref options 'reference #f)) + (readable? (option-ref options 'readable #f)) + (writable? (option-ref options 'writable #f)) + (executable? (option-ref options 'executable? #f)) + (xecutable? (option-ref options 'xecutable? #f)) + (usage? (and (not help?) + (< (length files) (if (or reference + readable? + writable? + executable? + xecutable?) 1 2))))) + (cond (version? (format #t "chmod (GASH) ~a\n" %version) (exit 0)) + ((or help? usage?) (format (if usage? (current-error-port) #t) + "\ +Usage: chmod [OPTION]... {MODE | --reference=REF_FILE} FILE... +Change the mode of each FILE to MODE. +With --reference, change the mode of each FILE to that of RFILE. + +Options: + --help display this help and exit + -R, --recursive change files and directories recursively + --reference=RFILE use RFILE's mode instead of MODE values + --version output version information and exit + +Each MODE is of the form '[ugoa]*([-+=]([rwxXst]*|[ugo]))+|[-+=][0-7]+'. +") + (exit (if usage? 2 0))) + (else + (receive (modifiers files) + (cond + (reference (values (list (make-numeric-chmodifier + (stat:mode (stat reference)))) files)) + ((or readable? writable? executable? xecutable?) + (let* ((m '()) + (m (if readable? (cons (make-chmodifier 'o '- '(r)) m) m)) + (m (if writable? (cons (make-chmodifier 'o '- '(w)) m) m)) + (m (if executable? (cons (make-chmodifier 'o '- '(x)) m) m)) + (m (if xecutable? (cons (make-chmodifier 'o '- '(X)) m) m))) + (values m files))) + (else (values (parse-modifiers (car files)) (cdr files)))) + (let ((files (if (option-ref options 'recursive #f) (append-map find-files files) + files))) + (for-each (cut apply-chmodifiers <> modifiers) files))))))) + +(define main chmod) From ac30e252bdbd7f3b1f7061903c0a0fad038b866e Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 3 Nov 2018 08:07:04 +0100 Subject: [PATCH 192/312] Make dependency on geesh optional. --- gash/geesh.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/gash/geesh.scm b/gash/geesh.scm index b5796b1..73e4fa6 100644 --- a/gash/geesh.scm +++ b/gash/geesh.scm @@ -25,12 +25,16 @@ #:use-module (gash builtins) #:use-module (gash gash) #:use-module (gash io) - #:use-module (geesh parser) #:export ( parse parse-string )) +(catch #t + (lambda _ (use-modules (geesh parser))) + (lambda (key . args) + #t)) + (define (parse port) (let ((parse-tree (read-sh-all port))) (when (> %debug-level 1) From a0ff0853ff4a8b75c23fd4f69e9c39d6b3ccfd60 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 3 Nov 2018 08:36:18 +0100 Subject: [PATCH 193/312] set: Support -u, clumped singles. * gash/builtins.scm (set-command): Support -u, clumped singles. * gash/environment.scm (variable): Consider `nounset'. TODO: propagate error. --- gash/builtins.scm | 10 +++++++++- gash/environment.scm | 14 ++++++++++---- 2 files changed, 19 insertions(+), 5 deletions(-) diff --git a/gash/builtins.scm b/gash/builtins.scm index ddded24..db08989 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -101,8 +101,16 @@ (() (lambda _ (for-each display-var %global-variables))) (("-e") (set-shell-opt! "errexit" #t)) (("+e") (set-shell-opt! "errexit" #f)) + (("-u") (set-shell-opt! "nounset" #t)) + (("+u") (set-shell-opt! "nounset" #f)) (("-x") (set-shell-opt! "xtrace" #t)) - (("+x") (set-shell-opt! "xtrace" #f)))) + (("+x") (set-shell-opt! "xtrace" #f)) + (((and (? string?) arg)) (let* ((lst (map (cut make-string 1 <>) (string->list arg))) + (set (car lst))) + (when (not (member set '("-" "+"))) + (error (format #f "set: no such option:~s\n" args))) + (apply set-command (map (cut string-append set <>) (cdr lst))))) + ((h ...) (last (map set-command args))))) (define (eval-command . args) (lambda _ diff --git a/gash/environment.scm b/gash/environment.scm index 5569d44..815e171 100644 --- a/gash/environment.scm +++ b/gash/environment.scm @@ -45,13 +45,19 @@ (environ))))) (define (assignment name value) - (set! %global-variables - (assoc-set! %global-variables name value)) - #t) + (and value + (set! %global-variables + (assoc-set! %global-variables name value)) + #t)) (define (variable name) (let ((name (if (string-prefix? "$" name) (string-drop name 1) name))) - (or (assoc-ref %global-variables name) ""))) + (or (assoc-ref %global-variables name) + (if (shell-opt? "nounset") (begin + ;; TODO: throw/error + (format (current-error-port) "gash: ~a: unbound variable\n" name) + #f) + "")))) (define (set-shell-opt! name set?) (let* ((shell-opts (variable "SHELLOPTS")) From 418652bee1a6430f76f96dd31cd7f497d8d941fa Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 3 Nov 2018 11:29:34 +0100 Subject: [PATCH 194/312] test: Refactor. --- check.sh | 85 ++++++++++--------- test/03-echo-escaped-doublequotes.sh | 1 + test/03-echo-escaped-doublequotes.stdout | 1 + test/{nesting.sh => 03-echo-nesting.sh} | 0 ...{nesting.stdout => 03-echo-nesting.stdout} | 0 test/03-echo-quoted-doublequotes.sh | 1 + test/03-echo-quoted-doublequotes.stdout | 1 + test/04-echo-equal.sh | 1 + test/04-echo-equal.stdout | 1 + ...ubstitute.sh => 05-assignment-backtick.sh} | 0 ...e.stdout => 05-assignment-backtick.stdout} | 0 ...05-assignment-doublequoted-doublequotes.sh | 3 +- ...ssignment-doublequoted-doublequotes.stdout | 2 +- ...-echo.stdout => 05-assignment-echo.stdout} | 0 test/05-assignment-empty.sh | 2 +- test/05-assignment-empty.stdout | 2 +- test/05-assignment-variable-word.sh | 4 +- test/05-assignment-variable-word.stdout | 1 + test/05-assignment-word-variable.sh | 3 + test/05-assignment-word-variable.stdout | 1 + ...nd-word.sh => 06-command-compound-word.sh} | 0 ...stdout => 06-command-compound-word.stdout} | 0 ...9-compound-word.sh => 06-compound-word.sh} | 0 ...nd-word.stdout => 06-compound-word.stdout} | 0 test/{11-if-false.sh => 10-if-false.sh} | 0 test/10-if-word-variable.sh | 4 + test/{00-sed-case.sh => 100-sed-case.sh} | 0 ...00-sed-case.stdout => 100-sed-case.stdout} | 0 test/100-sed-file.sh | 1 + test/100-sed-file.stdout | 3 + test/{00-sed-global.sh => 100-sed-global.sh} | 0 ...ed-global.stdout => 100-sed-global.stdout} | 0 ...-extended.sh => 100-sed-group-extended.sh} | 0 ...d.stdout => 100-sed-group-extended.stdout} | 0 test/{00-sed-group.sh => 100-sed-group.sh} | 0 ...-sed-group.stdout => 100-sed-group.stdout} | 0 test/{00-sed-once.sh => 100-sed-once.sh} | 0 ...00-sed-once.stdout => 100-sed-once.stdout} | 0 test/{00-sed-twice.sh => 100-sed-twice.sh} | 0 ...-sed-twice.stdout => 100-sed-twice.stdout} | 0 test/{00-sed-undo.sh => 100-sed-undo.sh} | 0 ...00-sed-undo.stdout => 100-sed-undo.stdout} | 0 test/{00-sed.sh => 100-sed.sh} | 0 test/{00-sed.stdout => 100-sed.stdout} | 0 test/{00-tar-Z-old.sh => 100-tar-Z-old.sh} | 0 ...-tar-Z-old.stdout => 100-tar-Z-old.stdout} | 0 test/{00-tar-Z-pipe.sh => 100-tar-Z-pipe.sh} | 0 ...ar-Z-pipe.stdout => 100-tar-Z-pipe.stdout} | 0 test/{00-tar-Z.sh => 100-tar-Z.sh} | 0 test/{00-tar-Z.stdout => 100-tar-Z.stdout} | 0 test/{00-tar.sh => 100-tar.sh} | 0 test/{00-tar.stdout => 100-tar.stdout} | 0 ...t-sequence.sh => 11-for-split-sequence.sh} | 0 ...ce.stdout => 11-for-split-sequence.stdout} | 0 test/{for.sh => 11-for.sh} | 0 test/11-for.stdout | 3 + ...1-pipe-exit-1.exit => 20-pipe-exit-1.exit} | 0 test/{21-pipe-exit-1.sh => 20-pipe-exit-1.sh} | 0 test/{pipe-3.sh => 20-pipe-sed-cat.sh} | 0 .../{pipe-3.stdout => 20-pipe-sed-cat.stdout} | 0 test/{pipe.sh => 20-pipe-sed.sh} | 0 test/{pipe.stdout => 20-pipe-sed.stdout} | 0 ...{22-semi-pipe-exit-0.exit => 20-semi.exit} | 0 test/{22-semi-pipe-exit-0.sh => 20-semi.sh} | 0 test/30-for-substitution.sh | 3 + test/30-for-substitution.stdout | 2 + ...ution.sh => 30-substitution-assignment.sh} | 0 test/30-substitution-assignment.stdout | 1 + test/30-substitution-backtick.sh | 1 + test/30-substitution-backtick.stdout | 1 + test/30-substitution.sh | 1 + test/30-substitution.stdout | 1 + test/32-for-substitute.sh | 3 - test/32-for-substitute.stdout | 2 - test/33-string-args.sh | 1 - test/35-assignment-eval-echo.sh | 1 - test/40-assignment-eval-echo.sh | 3 + test/40-assignment-eval-echo.stdout | 1 + ...o-variable.sh => 40-eval-echo-variable.sh} | 3 +- test/40-eval-echo-variable.stdout | 1 + test/{30-eval.sh => 40-eval.sh} | 0 test/40-eval.stdout | 1 + test/{iohere.sh => 50-iohere.sh} | 0 test/{iohere.stdout => 50-iohere.stdout} | 0 test/assign.sh | 2 - test/assign2.sh | 3 - test/find.sh | 1 - test/if2.sh | 3 - test/list.sh | 1 - test/ls.sh | 1 - test/substitution.sh | 2 - 91 files changed, 93 insertions(+), 66 deletions(-) create mode 100644 test/03-echo-escaped-doublequotes.sh create mode 100644 test/03-echo-escaped-doublequotes.stdout rename test/{nesting.sh => 03-echo-nesting.sh} (100%) rename test/{nesting.stdout => 03-echo-nesting.stdout} (100%) create mode 100644 test/03-echo-quoted-doublequotes.sh create mode 100644 test/03-echo-quoted-doublequotes.stdout create mode 100644 test/04-echo-equal.sh create mode 100644 test/04-echo-equal.stdout rename test/{0a-assign-substitute.sh => 05-assignment-backtick.sh} (100%) rename test/{0a-assign-substitute.stdout => 05-assignment-backtick.stdout} (100%) rename test/{06-assignment-echo.stdout => 05-assignment-echo.stdout} (100%) create mode 100644 test/05-assignment-variable-word.stdout create mode 100644 test/05-assignment-word-variable.sh create mode 100644 test/05-assignment-word-variable.stdout rename test/{0b-command-compound-word.sh => 06-command-compound-word.sh} (100%) rename test/{0b-command-compound-word.stdout => 06-command-compound-word.stdout} (100%) rename test/{09-compound-word.sh => 06-compound-word.sh} (100%) rename test/{09-compound-word.stdout => 06-compound-word.stdout} (100%) rename test/{11-if-false.sh => 10-if-false.sh} (100%) create mode 100644 test/10-if-word-variable.sh rename test/{00-sed-case.sh => 100-sed-case.sh} (100%) rename test/{00-sed-case.stdout => 100-sed-case.stdout} (100%) create mode 100644 test/100-sed-file.sh create mode 100644 test/100-sed-file.stdout rename test/{00-sed-global.sh => 100-sed-global.sh} (100%) rename test/{00-sed-global.stdout => 100-sed-global.stdout} (100%) rename test/{00-sed-group-extended.sh => 100-sed-group-extended.sh} (100%) rename test/{00-sed-group-extended.stdout => 100-sed-group-extended.stdout} (100%) rename test/{00-sed-group.sh => 100-sed-group.sh} (100%) rename test/{00-sed-group.stdout => 100-sed-group.stdout} (100%) rename test/{00-sed-once.sh => 100-sed-once.sh} (100%) rename test/{00-sed-once.stdout => 100-sed-once.stdout} (100%) rename test/{00-sed-twice.sh => 100-sed-twice.sh} (100%) rename test/{00-sed-twice.stdout => 100-sed-twice.stdout} (100%) rename test/{00-sed-undo.sh => 100-sed-undo.sh} (100%) rename test/{00-sed-undo.stdout => 100-sed-undo.stdout} (100%) rename test/{00-sed.sh => 100-sed.sh} (100%) rename test/{00-sed.stdout => 100-sed.stdout} (100%) rename test/{00-tar-Z-old.sh => 100-tar-Z-old.sh} (100%) rename test/{00-tar-Z-old.stdout => 100-tar-Z-old.stdout} (100%) rename test/{00-tar-Z-pipe.sh => 100-tar-Z-pipe.sh} (100%) rename test/{00-tar-Z-pipe.stdout => 100-tar-Z-pipe.stdout} (100%) rename test/{00-tar-Z.sh => 100-tar-Z.sh} (100%) rename test/{00-tar-Z.stdout => 100-tar-Z.stdout} (100%) rename test/{00-tar.sh => 100-tar.sh} (100%) rename test/{00-tar.stdout => 100-tar.stdout} (100%) rename test/{for-split-sequence.sh => 11-for-split-sequence.sh} (100%) rename test/{for-split-sequence.stdout => 11-for-split-sequence.stdout} (100%) rename test/{for.sh => 11-for.sh} (100%) create mode 100644 test/11-for.stdout rename test/{21-pipe-exit-1.exit => 20-pipe-exit-1.exit} (100%) rename test/{21-pipe-exit-1.sh => 20-pipe-exit-1.sh} (100%) rename test/{pipe-3.sh => 20-pipe-sed-cat.sh} (100%) rename test/{pipe-3.stdout => 20-pipe-sed-cat.stdout} (100%) rename test/{pipe.sh => 20-pipe-sed.sh} (100%) rename test/{pipe.stdout => 20-pipe-sed.stdout} (100%) rename test/{22-semi-pipe-exit-0.exit => 20-semi.exit} (100%) rename test/{22-semi-pipe-exit-0.sh => 20-semi.sh} (100%) create mode 100644 test/30-for-substitution.sh create mode 100644 test/30-for-substitution.stdout rename test/{30-assignment-substitution.sh => 30-substitution-assignment.sh} (100%) create mode 100644 test/30-substitution-assignment.stdout create mode 100644 test/30-substitution-backtick.sh create mode 100644 test/30-substitution-backtick.stdout create mode 100644 test/30-substitution.sh create mode 100644 test/30-substitution.stdout delete mode 100644 test/32-for-substitute.sh delete mode 100644 test/32-for-substitute.stdout delete mode 100644 test/33-string-args.sh delete mode 100644 test/35-assignment-eval-echo.sh create mode 100644 test/40-assignment-eval-echo.sh create mode 100644 test/40-assignment-eval-echo.stdout rename test/{31-eval-echo-variable.sh => 40-eval-echo-variable.sh} (52%) create mode 100644 test/40-eval-echo-variable.stdout rename test/{30-eval.sh => 40-eval.sh} (100%) create mode 100644 test/40-eval.stdout rename test/{iohere.sh => 50-iohere.sh} (100%) rename test/{iohere.stdout => 50-iohere.stdout} (100%) delete mode 100644 test/assign.sh delete mode 100644 test/assign2.sh delete mode 100644 test/find.sh delete mode 100644 test/if2.sh delete mode 100644 test/list.sh delete mode 100644 test/ls.sh delete mode 100644 test/substitution.sh diff --git a/check.sh b/check.sh index c6e5c5c..0de585e 100755 --- a/check.sh +++ b/check.sh @@ -5,59 +5,66 @@ DIFF=diff SHELL=${SHELL-bin/gash} tests=" -assign -assign2 -for -for-split-sequence -find -if2 -iohere -list -ls -nesting -pipe -pipe-3 -substitution 00-exit 01-exit-0 02-exit-1 + 03-echo +03-echo-nesting +03-echo-escaped-doublequotes +03-echo-quoted-doublequotes + 04-echo-var -05-assignment-doublequoted-doublequotes +04-echo-equal + 05-assignment -05-assignment-empty 05-assignment-echo +05-assignment-empty 05-assignment-singlequote 05-assignment-double-quote 05-assignment-variable-word -09-compound-word -0a-assign-substitute -0b-command-compound-word +05-assignment-word-variable +05-assignment-doublequoted-doublequotes + +06-compound-word +06-command-compound-word + 10-if -11-if-false +10-if-false +10-if-word-variable +11-for +11-for-split-sequence + +20-semi.sh 20-pipe-exit-0 -21-pipe-exit-1 -22-semi-pipe-exit-0 -30-assignment-substitution -30-eval -31-eval-echo-variable -32-for-substitute -33-string-args -35-assignment-eval-echo +20-pipe-exit-1 +20-pipe-sed -00-sed -00-sed-once -00-sed-global -00-sed-case -00-sed-group -00-sed-group-extended -00-sed-twice -00-sed-undo +30-substitution +30-substitution-backtick +30-substitution-assignment +30-for-substitution -00-tar -00-tar-Z -00-tar-Z-old -00-tar-Z-pipe +40-eval +40-eval-echo-variable +40-assignment-eval-echo.sh + +50-iohere + +100-sed +100-sed-once +100-sed-global +100-sed-case +100-sed-group +100-sed-group-extended +100-sed-twice +100-sed-undo +100-sed-file + +100-tar +100-tar-Z +100-tar-Z-old +100-tar-Z-pipe " broken=" diff --git a/test/03-echo-escaped-doublequotes.sh b/test/03-echo-escaped-doublequotes.sh new file mode 100644 index 0000000..125a6e5 --- /dev/null +++ b/test/03-echo-escaped-doublequotes.sh @@ -0,0 +1 @@ +echo foo "bar" \"baz\" diff --git a/test/03-echo-escaped-doublequotes.stdout b/test/03-echo-escaped-doublequotes.stdout new file mode 100644 index 0000000..80a5f14 --- /dev/null +++ b/test/03-echo-escaped-doublequotes.stdout @@ -0,0 +1 @@ +foo bar "baz" diff --git a/test/nesting.sh b/test/03-echo-nesting.sh similarity index 100% rename from test/nesting.sh rename to test/03-echo-nesting.sh diff --git a/test/nesting.stdout b/test/03-echo-nesting.stdout similarity index 100% rename from test/nesting.stdout rename to test/03-echo-nesting.stdout diff --git a/test/03-echo-quoted-doublequotes.sh b/test/03-echo-quoted-doublequotes.sh new file mode 100644 index 0000000..3e4148a --- /dev/null +++ b/test/03-echo-quoted-doublequotes.sh @@ -0,0 +1 @@ +echo foo "bar" '"baz"' diff --git a/test/03-echo-quoted-doublequotes.stdout b/test/03-echo-quoted-doublequotes.stdout new file mode 100644 index 0000000..80a5f14 --- /dev/null +++ b/test/03-echo-quoted-doublequotes.stdout @@ -0,0 +1 @@ +foo bar "baz" diff --git a/test/04-echo-equal.sh b/test/04-echo-equal.sh new file mode 100644 index 0000000..86d3494 --- /dev/null +++ b/test/04-echo-equal.sh @@ -0,0 +1 @@ +echo a=$a diff --git a/test/04-echo-equal.stdout b/test/04-echo-equal.stdout new file mode 100644 index 0000000..2afe6dc --- /dev/null +++ b/test/04-echo-equal.stdout @@ -0,0 +1 @@ +a= diff --git a/test/0a-assign-substitute.sh b/test/05-assignment-backtick.sh similarity index 100% rename from test/0a-assign-substitute.sh rename to test/05-assignment-backtick.sh diff --git a/test/0a-assign-substitute.stdout b/test/05-assignment-backtick.stdout similarity index 100% rename from test/0a-assign-substitute.stdout rename to test/05-assignment-backtick.stdout diff --git a/test/05-assignment-doublequoted-doublequotes.sh b/test/05-assignment-doublequoted-doublequotes.sh index ef6751f..173a49a 100644 --- a/test/05-assignment-doublequoted-doublequotes.sh +++ b/test/05-assignment-doublequoted-doublequotes.sh @@ -1,5 +1,4 @@ -#set -x aliaspath=alias -localedir=x +localedir=locale defines="-DALIASPATH=\"${aliaspath}\" -DLOCALEDIR=\"${localedir}\"" echo cc $defines diff --git a/test/05-assignment-doublequoted-doublequotes.stdout b/test/05-assignment-doublequoted-doublequotes.stdout index 5380254..4ea0763 100644 --- a/test/05-assignment-doublequoted-doublequotes.stdout +++ b/test/05-assignment-doublequoted-doublequotes.stdout @@ -1 +1 @@ -cc -DALIASPATH="alias" -DLOCALEDIR="x" +cc -DALIASPATH="alias" -DLOCALEDIR="locale" diff --git a/test/06-assignment-echo.stdout b/test/05-assignment-echo.stdout similarity index 100% rename from test/06-assignment-echo.stdout rename to test/05-assignment-echo.stdout diff --git a/test/05-assignment-empty.sh b/test/05-assignment-empty.sh index 6aba02a..049544d 100644 --- a/test/05-assignment-empty.sh +++ b/test/05-assignment-empty.sh @@ -1,2 +1,2 @@ a= -echo a=$a +echo a:$a diff --git a/test/05-assignment-empty.stdout b/test/05-assignment-empty.stdout index 2afe6dc..46568d8 100644 --- a/test/05-assignment-empty.stdout +++ b/test/05-assignment-empty.stdout @@ -1 +1 @@ -a= +a: diff --git a/test/05-assignment-variable-word.sh b/test/05-assignment-variable-word.sh index 4525fdf..dbc2719 100644 --- a/test/05-assignment-variable-word.sh +++ b/test/05-assignment-variable-word.sh @@ -1 +1,3 @@ -libdir=${exec_prefix}/lib +SHELL=gash +bin=${SHELL}/bin +echo $bin diff --git a/test/05-assignment-variable-word.stdout b/test/05-assignment-variable-word.stdout new file mode 100644 index 0000000..567d244 --- /dev/null +++ b/test/05-assignment-variable-word.stdout @@ -0,0 +1 @@ +gash/bin diff --git a/test/05-assignment-word-variable.sh b/test/05-assignment-word-variable.sh new file mode 100644 index 0000000..95d0e68 --- /dev/null +++ b/test/05-assignment-word-variable.sh @@ -0,0 +1,3 @@ +SHELL=gash +PATH=bin:${SHELL} +echo $PATH diff --git a/test/05-assignment-word-variable.stdout b/test/05-assignment-word-variable.stdout new file mode 100644 index 0000000..62036dd --- /dev/null +++ b/test/05-assignment-word-variable.stdout @@ -0,0 +1 @@ +bin:gash diff --git a/test/0b-command-compound-word.sh b/test/06-command-compound-word.sh similarity index 100% rename from test/0b-command-compound-word.sh rename to test/06-command-compound-word.sh diff --git a/test/0b-command-compound-word.stdout b/test/06-command-compound-word.stdout similarity index 100% rename from test/0b-command-compound-word.stdout rename to test/06-command-compound-word.stdout diff --git a/test/09-compound-word.sh b/test/06-compound-word.sh similarity index 100% rename from test/09-compound-word.sh rename to test/06-compound-word.sh diff --git a/test/09-compound-word.stdout b/test/06-compound-word.stdout similarity index 100% rename from test/09-compound-word.stdout rename to test/06-compound-word.stdout diff --git a/test/11-if-false.sh b/test/10-if-false.sh similarity index 100% rename from test/11-if-false.sh rename to test/10-if-false.sh diff --git a/test/10-if-word-variable.sh b/test/10-if-word-variable.sh new file mode 100644 index 0000000..5902433 --- /dev/null +++ b/test/10-if-word-variable.sh @@ -0,0 +1,4 @@ +if [ x"$y" = x ]; then + exit 0 +fi +exit 1 diff --git a/test/00-sed-case.sh b/test/100-sed-case.sh similarity index 100% rename from test/00-sed-case.sh rename to test/100-sed-case.sh diff --git a/test/00-sed-case.stdout b/test/100-sed-case.stdout similarity index 100% rename from test/00-sed-case.stdout rename to test/100-sed-case.stdout diff --git a/test/100-sed-file.sh b/test/100-sed-file.sh new file mode 100644 index 0000000..635bcdb --- /dev/null +++ b/test/100-sed-file.sh @@ -0,0 +1 @@ +\sed s,foo,bar, test/data/foo diff --git a/test/100-sed-file.stdout b/test/100-sed-file.stdout new file mode 100644 index 0000000..52d6430 --- /dev/null +++ b/test/100-sed-file.stdout @@ -0,0 +1,3 @@ +bar +bar +baz diff --git a/test/00-sed-global.sh b/test/100-sed-global.sh similarity index 100% rename from test/00-sed-global.sh rename to test/100-sed-global.sh diff --git a/test/00-sed-global.stdout b/test/100-sed-global.stdout similarity index 100% rename from test/00-sed-global.stdout rename to test/100-sed-global.stdout diff --git a/test/00-sed-group-extended.sh b/test/100-sed-group-extended.sh similarity index 100% rename from test/00-sed-group-extended.sh rename to test/100-sed-group-extended.sh diff --git a/test/00-sed-group-extended.stdout b/test/100-sed-group-extended.stdout similarity index 100% rename from test/00-sed-group-extended.stdout rename to test/100-sed-group-extended.stdout diff --git a/test/00-sed-group.sh b/test/100-sed-group.sh similarity index 100% rename from test/00-sed-group.sh rename to test/100-sed-group.sh diff --git a/test/00-sed-group.stdout b/test/100-sed-group.stdout similarity index 100% rename from test/00-sed-group.stdout rename to test/100-sed-group.stdout diff --git a/test/00-sed-once.sh b/test/100-sed-once.sh similarity index 100% rename from test/00-sed-once.sh rename to test/100-sed-once.sh diff --git a/test/00-sed-once.stdout b/test/100-sed-once.stdout similarity index 100% rename from test/00-sed-once.stdout rename to test/100-sed-once.stdout diff --git a/test/00-sed-twice.sh b/test/100-sed-twice.sh similarity index 100% rename from test/00-sed-twice.sh rename to test/100-sed-twice.sh diff --git a/test/00-sed-twice.stdout b/test/100-sed-twice.stdout similarity index 100% rename from test/00-sed-twice.stdout rename to test/100-sed-twice.stdout diff --git a/test/00-sed-undo.sh b/test/100-sed-undo.sh similarity index 100% rename from test/00-sed-undo.sh rename to test/100-sed-undo.sh diff --git a/test/00-sed-undo.stdout b/test/100-sed-undo.stdout similarity index 100% rename from test/00-sed-undo.stdout rename to test/100-sed-undo.stdout diff --git a/test/00-sed.sh b/test/100-sed.sh similarity index 100% rename from test/00-sed.sh rename to test/100-sed.sh diff --git a/test/00-sed.stdout b/test/100-sed.stdout similarity index 100% rename from test/00-sed.stdout rename to test/100-sed.stdout diff --git a/test/00-tar-Z-old.sh b/test/100-tar-Z-old.sh similarity index 100% rename from test/00-tar-Z-old.sh rename to test/100-tar-Z-old.sh diff --git a/test/00-tar-Z-old.stdout b/test/100-tar-Z-old.stdout similarity index 100% rename from test/00-tar-Z-old.stdout rename to test/100-tar-Z-old.stdout diff --git a/test/00-tar-Z-pipe.sh b/test/100-tar-Z-pipe.sh similarity index 100% rename from test/00-tar-Z-pipe.sh rename to test/100-tar-Z-pipe.sh diff --git a/test/00-tar-Z-pipe.stdout b/test/100-tar-Z-pipe.stdout similarity index 100% rename from test/00-tar-Z-pipe.stdout rename to test/100-tar-Z-pipe.stdout diff --git a/test/00-tar-Z.sh b/test/100-tar-Z.sh similarity index 100% rename from test/00-tar-Z.sh rename to test/100-tar-Z.sh diff --git a/test/00-tar-Z.stdout b/test/100-tar-Z.stdout similarity index 100% rename from test/00-tar-Z.stdout rename to test/100-tar-Z.stdout diff --git a/test/00-tar.sh b/test/100-tar.sh similarity index 100% rename from test/00-tar.sh rename to test/100-tar.sh diff --git a/test/00-tar.stdout b/test/100-tar.stdout similarity index 100% rename from test/00-tar.stdout rename to test/100-tar.stdout diff --git a/test/for-split-sequence.sh b/test/11-for-split-sequence.sh similarity index 100% rename from test/for-split-sequence.sh rename to test/11-for-split-sequence.sh diff --git a/test/for-split-sequence.stdout b/test/11-for-split-sequence.stdout similarity index 100% rename from test/for-split-sequence.stdout rename to test/11-for-split-sequence.stdout diff --git a/test/for.sh b/test/11-for.sh similarity index 100% rename from test/for.sh rename to test/11-for.sh diff --git a/test/11-for.stdout b/test/11-for.stdout new file mode 100644 index 0000000..4539bbf --- /dev/null +++ b/test/11-for.stdout @@ -0,0 +1,3 @@ +0 +1 +2 diff --git a/test/21-pipe-exit-1.exit b/test/20-pipe-exit-1.exit similarity index 100% rename from test/21-pipe-exit-1.exit rename to test/20-pipe-exit-1.exit diff --git a/test/21-pipe-exit-1.sh b/test/20-pipe-exit-1.sh similarity index 100% rename from test/21-pipe-exit-1.sh rename to test/20-pipe-exit-1.sh diff --git a/test/pipe-3.sh b/test/20-pipe-sed-cat.sh similarity index 100% rename from test/pipe-3.sh rename to test/20-pipe-sed-cat.sh diff --git a/test/pipe-3.stdout b/test/20-pipe-sed-cat.stdout similarity index 100% rename from test/pipe-3.stdout rename to test/20-pipe-sed-cat.stdout diff --git a/test/pipe.sh b/test/20-pipe-sed.sh similarity index 100% rename from test/pipe.sh rename to test/20-pipe-sed.sh diff --git a/test/pipe.stdout b/test/20-pipe-sed.stdout similarity index 100% rename from test/pipe.stdout rename to test/20-pipe-sed.stdout diff --git a/test/22-semi-pipe-exit-0.exit b/test/20-semi.exit similarity index 100% rename from test/22-semi-pipe-exit-0.exit rename to test/20-semi.exit diff --git a/test/22-semi-pipe-exit-0.sh b/test/20-semi.sh similarity index 100% rename from test/22-semi-pipe-exit-0.sh rename to test/20-semi.sh diff --git a/test/30-for-substitution.sh b/test/30-for-substitution.sh new file mode 100644 index 0000000..a216a82 --- /dev/null +++ b/test/30-for-substitution.sh @@ -0,0 +1,3 @@ +for file in `echo foo.o bar.o`; do + echo compiling $file... +done diff --git a/test/30-for-substitution.stdout b/test/30-for-substitution.stdout new file mode 100644 index 0000000..aff4123 --- /dev/null +++ b/test/30-for-substitution.stdout @@ -0,0 +1,2 @@ +compiling foo.o... +compiling bar.o... diff --git a/test/30-assignment-substitution.sh b/test/30-substitution-assignment.sh similarity index 100% rename from test/30-assignment-substitution.sh rename to test/30-substitution-assignment.sh diff --git a/test/30-substitution-assignment.stdout b/test/30-substitution-assignment.stdout new file mode 100644 index 0000000..94facae --- /dev/null +++ b/test/30-substitution-assignment.stdout @@ -0,0 +1 @@ +b=test/test diff --git a/test/30-substitution-backtick.sh b/test/30-substitution-backtick.sh new file mode 100644 index 0000000..f196ae2 --- /dev/null +++ b/test/30-substitution-backtick.sh @@ -0,0 +1 @@ +echo `echo 1 2 3` diff --git a/test/30-substitution-backtick.stdout b/test/30-substitution-backtick.stdout new file mode 100644 index 0000000..b85905e --- /dev/null +++ b/test/30-substitution-backtick.stdout @@ -0,0 +1 @@ +1 2 3 diff --git a/test/30-substitution.sh b/test/30-substitution.sh new file mode 100644 index 0000000..a5c0e5c --- /dev/null +++ b/test/30-substitution.sh @@ -0,0 +1 @@ +echo $(echo 1 2 3) diff --git a/test/30-substitution.stdout b/test/30-substitution.stdout new file mode 100644 index 0000000..b85905e --- /dev/null +++ b/test/30-substitution.stdout @@ -0,0 +1 @@ +1 2 3 diff --git a/test/32-for-substitute.sh b/test/32-for-substitute.sh deleted file mode 100644 index 3a5b9ee..0000000 --- a/test/32-for-substitute.sh +++ /dev/null @@ -1,3 +0,0 @@ -for file in `echo ar.o arscan.o`; do - echo compiling $file... -done diff --git a/test/32-for-substitute.stdout b/test/32-for-substitute.stdout deleted file mode 100644 index ec37551..0000000 --- a/test/32-for-substitute.stdout +++ /dev/null @@ -1,2 +0,0 @@ -compiling ar.o... -compiling arscan.o... diff --git a/test/33-string-args.sh b/test/33-string-args.sh deleted file mode 100644 index 0abb456..0000000 --- a/test/33-string-args.sh +++ /dev/null @@ -1 +0,0 @@ -echo foo "bar" '"baz"' \"bla\" diff --git a/test/35-assignment-eval-echo.sh b/test/35-assignment-eval-echo.sh deleted file mode 100644 index 905da22..0000000 --- a/test/35-assignment-eval-echo.sh +++ /dev/null @@ -1 +0,0 @@ -exec_prefix=`eval echo ${prefix}` diff --git a/test/40-assignment-eval-echo.sh b/test/40-assignment-eval-echo.sh new file mode 100644 index 0000000..0bad8d8 --- /dev/null +++ b/test/40-assignment-eval-echo.sh @@ -0,0 +1,3 @@ +foo=bar +baz=`eval echo ${foo}` +echo $baz diff --git a/test/40-assignment-eval-echo.stdout b/test/40-assignment-eval-echo.stdout new file mode 100644 index 0000000..5716ca5 --- /dev/null +++ b/test/40-assignment-eval-echo.stdout @@ -0,0 +1 @@ +bar diff --git a/test/31-eval-echo-variable.sh b/test/40-eval-echo-variable.sh similarity index 52% rename from test/31-eval-echo-variable.sh rename to test/40-eval-echo-variable.sh index 5882a93..1d4916d 100644 --- a/test/31-eval-echo-variable.sh +++ b/test/40-eval-echo-variable.sh @@ -1,2 +1,3 @@ -bar=SHELL +foo=baz +bar=foo eval echo '$'$bar diff --git a/test/40-eval-echo-variable.stdout b/test/40-eval-echo-variable.stdout new file mode 100644 index 0000000..7601807 --- /dev/null +++ b/test/40-eval-echo-variable.stdout @@ -0,0 +1 @@ +baz diff --git a/test/30-eval.sh b/test/40-eval.sh similarity index 100% rename from test/30-eval.sh rename to test/40-eval.sh diff --git a/test/40-eval.stdout b/test/40-eval.stdout new file mode 100644 index 0000000..573541a --- /dev/null +++ b/test/40-eval.stdout @@ -0,0 +1 @@ +0 diff --git a/test/iohere.sh b/test/50-iohere.sh similarity index 100% rename from test/iohere.sh rename to test/50-iohere.sh diff --git a/test/iohere.stdout b/test/50-iohere.stdout similarity index 100% rename from test/iohere.stdout rename to test/50-iohere.stdout diff --git a/test/assign.sh b/test/assign.sh deleted file mode 100644 index c960245..0000000 --- a/test/assign.sh +++ /dev/null @@ -1,2 +0,0 @@ - -ALLOCA='' diff --git a/test/assign2.sh b/test/assign2.sh deleted file mode 100644 index 5a9c238..0000000 --- a/test/assign2.sh +++ /dev/null @@ -1,3 +0,0 @@ -defines="-DALIASPATH=\"${aliaspath}\" -" -echo defines:$defines - diff --git a/test/find.sh b/test/find.sh deleted file mode 100644 index 190b922..0000000 --- a/test/find.sh +++ /dev/null @@ -1 +0,0 @@ -find test -type f diff --git a/test/if2.sh b/test/if2.sh deleted file mode 100644 index 7532af5..0000000 --- a/test/if2.sh +++ /dev/null @@ -1,3 +0,0 @@ -if [ x"$y" != x ]; then - echo "boo" -fi diff --git a/test/list.sh b/test/list.sh deleted file mode 100644 index 7951df4..0000000 --- a/test/list.sh +++ /dev/null @@ -1 +0,0 @@ -echo *e*a*;echo *r?p*;echo *;echo [a-l]*[m-z]*; echo; diff --git a/test/ls.sh b/test/ls.sh deleted file mode 100644 index 0b5dbb1..0000000 --- a/test/ls.sh +++ /dev/null @@ -1 +0,0 @@ -ls * diff --git a/test/substitution.sh b/test/substitution.sh deleted file mode 100644 index 8d686de..0000000 --- a/test/substitution.sh +++ /dev/null @@ -1,2 +0,0 @@ -echo $(find test -type f) -#echo `find test -type f` From bca65e807b9e45741334428e567f18ec2fe94f8e Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 3 Nov 2018 10:04:26 +0100 Subject: [PATCH 195/312] Support ${foob-bar} and ${foo+bar}. * gash/environment.scm (variable): Add default parameter. (variable-or, variable-and): New function. * test/07-variable-or.sh: Test it. * test/07-variable-or-not.sh: * test/08-variable-and.sh: * test/08-variable-and-not.sh: --- check.sh | 6 ++++++ gash/environment.scm | 13 +++++++++++-- gash/peg.scm | 29 +++++++++++++++++------------ test/07-variable-not-or.sh | 2 ++ test/07-variable-not-or.stdout | 1 + test/07-variable-or.sh | 1 + test/07-variable-or.stdout | 1 + test/08-variable-and.sh | 2 ++ test/08-variable-and.stdout | 1 + test/08-variable-not-and.sh | 1 + test/08-variable-not-and.stdout | 1 + 11 files changed, 44 insertions(+), 14 deletions(-) create mode 100644 test/07-variable-not-or.sh create mode 100644 test/07-variable-not-or.stdout create mode 100644 test/07-variable-or.sh create mode 100644 test/07-variable-or.stdout create mode 100644 test/08-variable-and.sh create mode 100644 test/08-variable-and.stdout create mode 100644 test/08-variable-not-and.sh create mode 100644 test/08-variable-not-and.stdout diff --git a/check.sh b/check.sh index 0de585e..9e0fec5 100755 --- a/check.sh +++ b/check.sh @@ -29,6 +29,12 @@ tests=" 06-compound-word 06-command-compound-word +07-variable-or +07-variable-not-or + +08-variable-and +08-variable-not-and + 10-if 10-if-false 10-if-word-variable diff --git a/gash/environment.scm b/gash/environment.scm index 815e171..1f4a329 100644 --- a/gash/environment.scm +++ b/gash/environment.scm @@ -29,6 +29,8 @@ set-shell-opt! shell-opt? variable + variable-and + variable-or )) ;; FIXME: export/env vs set @@ -50,14 +52,21 @@ (assoc-set! %global-variables name value)) #t)) -(define (variable name) +(define* (variable name #:optional (default "")) (let ((name (if (string-prefix? "$" name) (string-drop name 1) name))) (or (assoc-ref %global-variables name) (if (shell-opt? "nounset") (begin ;; TODO: throw/error (format (current-error-port) "gash: ~a: unbound variable\n" name) #f) - "")))) + default)))) + +(define (variable-or name default) + (variable name default)) + +(define (variable-and name default) + (let ((value (variable name #f))) + (and value default))) (define (set-shell-opt! name set?) (let* ((shell-opts (variable "SHELLOPTS")) diff --git a/gash/peg.scm b/gash/peg.scm index 3f38b82..6607109 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -212,30 +212,28 @@ filename <-- word name <-- identifier identifier <- [_a-zA-Z][_a-zA-Z0-9]* - oldword <- substitution / assignment / number / variable / delim / literal - - word-for-test-assign-sh <-- assignment / (delim / number / variable / literal)+ - word-for-test-if2-sh <-- assignment / delim / (number / variable / literal)+ - - word <-- assignment / (delim / number / variable / literal)+ - + word <-- assignment / delim / (number / variable / brace-variable / literal)+ number <-- [0-9]+ lsubst < '$(' rsubst < ')' tick < '`' substitution <-- lsubst script rsubst / tick script tick - assignment <-- name assign (substitution / word)* + assignment <-- name assign rhs + rhs <- (substitution / word)* assign < '=' - dollar <- '$' - literal <-- (!tick !dollar !pipe !semi !par !nl !sp .)+ - variable <-- dollar (dollar / '*' / '?' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}])) + dollar < '$' + literal <-- (!tick !dollar !pipe !semi !par !nl !sp !rbrace .)+ + variable <-- dollar ('$' / '*' / '?' / '@' / [0-9] / identifier) + brace-variable <- dollar lbrace (variable-or / variable-and / identifier) rbrace + variable-and <-- identifier plus rhs + variable-or <-- identifier minus rhs delim <- singlequotes / doublequotes / substitution sq < ['] dq < [\"] bt < [`] singlequotes <-- sq (doublequotes / (!sq .))* sq - doublequotes <-- dq (singlequotes / substitution / variable / (!dq .))* dq + doublequotes <-- dq (singlequotes / substitution / variable / variable-and-or / (!dq .))* dq break <- amp / semi !semi separator <- (sp* break ws*) / ws+ sequential-sep <- (semi !semi ws*) / ws+ @@ -243,6 +241,10 @@ semi < ';' lpar < '(' rpar < ')' + lbrace < [{] + rbrace < [}] + plus < [+] + minus < '-' par < lpar / rpar nl < '\n' sp < [\t ] @@ -282,6 +284,9 @@ ((('literal _ ...) _ ...) (map transform (flatten ast))) ((('pipeline _ ...) _ ...) (map transform (flatten ast))) ((('singlequotes _ ...) _ ...) (map transform (flatten ast))) + + ((('word _ ...) ('word _ ...)) (transform (cons 'word ast))) + ((('word _ ...) _ ...) (map transform (flatten ast))) (('script ('pipeline ('command command ... (word (literal "&"))))) diff --git a/test/07-variable-not-or.sh b/test/07-variable-not-or.sh new file mode 100644 index 0000000..a52d13b --- /dev/null +++ b/test/07-variable-not-or.sh @@ -0,0 +1,2 @@ +foo=baz +echo ${foo-bar} diff --git a/test/07-variable-not-or.stdout b/test/07-variable-not-or.stdout new file mode 100644 index 0000000..7601807 --- /dev/null +++ b/test/07-variable-not-or.stdout @@ -0,0 +1 @@ +baz diff --git a/test/07-variable-or.sh b/test/07-variable-or.sh new file mode 100644 index 0000000..4a2da2a --- /dev/null +++ b/test/07-variable-or.sh @@ -0,0 +1 @@ +echo ${foo-bar} diff --git a/test/07-variable-or.stdout b/test/07-variable-or.stdout new file mode 100644 index 0000000..5716ca5 --- /dev/null +++ b/test/07-variable-or.stdout @@ -0,0 +1 @@ +bar diff --git a/test/08-variable-and.sh b/test/08-variable-and.sh new file mode 100644 index 0000000..3c5da46 --- /dev/null +++ b/test/08-variable-and.sh @@ -0,0 +1,2 @@ +foo=baz +echo ${foo+bar} diff --git a/test/08-variable-and.stdout b/test/08-variable-and.stdout new file mode 100644 index 0000000..5716ca5 --- /dev/null +++ b/test/08-variable-and.stdout @@ -0,0 +1 @@ +bar diff --git a/test/08-variable-not-and.sh b/test/08-variable-not-and.sh new file mode 100644 index 0000000..af44487 --- /dev/null +++ b/test/08-variable-not-and.sh @@ -0,0 +1 @@ +echo ${foo+bar} diff --git a/test/08-variable-not-and.stdout b/test/08-variable-not-and.stdout new file mode 100644 index 0000000..8b13789 --- /dev/null +++ b/test/08-variable-not-and.stdout @@ -0,0 +1 @@ + From 2a4e3ec71b8bebcd552c2be997af5294fbbb8317 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 3 Nov 2018 12:53:39 +0100 Subject: [PATCH 196/312] Support escaped newline. * gash/peg.scm (parse-): Support escaped newline. * test/01-script-backslash.sh: Test it. --- check.sh | 10 +++++++-- gash/peg.scm | 27 +++++++++++-------------- test/{01-exit-0.sh => 00-exit-0.sh} | 0 test/{02-exit-1.exit => 00-exit-1.exit} | 0 test/{02-exit-1.sh => 00-exit-1.sh} | 0 test/01-script-backslash-space.sh | 4 ++++ test/01-script-backslash-twice.exit | 1 + test/01-script-backslash-twice.sh | 3 +++ test/01-script-backslash.exit | 1 + test/01-script-backslash.sh | 2 ++ test/01-script-newline.exit | 1 + test/01-script-newline.sh | 2 ++ test/01-script-semi.exit | 1 + test/01-script-semi.sh | 1 + 14 files changed, 36 insertions(+), 17 deletions(-) rename test/{01-exit-0.sh => 00-exit-0.sh} (100%) rename test/{02-exit-1.exit => 00-exit-1.exit} (100%) rename test/{02-exit-1.sh => 00-exit-1.sh} (100%) create mode 100644 test/01-script-backslash-space.sh create mode 100644 test/01-script-backslash-twice.exit create mode 100644 test/01-script-backslash-twice.sh create mode 100644 test/01-script-backslash.exit create mode 100644 test/01-script-backslash.sh create mode 100644 test/01-script-newline.exit create mode 100644 test/01-script-newline.sh create mode 100644 test/01-script-semi.exit create mode 100644 test/01-script-semi.sh diff --git a/check.sh b/check.sh index 9e0fec5..0f03704 100755 --- a/check.sh +++ b/check.sh @@ -6,8 +6,14 @@ SHELL=${SHELL-bin/gash} tests=" 00-exit -01-exit-0 -02-exit-1 +00-exit-0 +00-exit-1 + +01-script-newline +01-script-semi +01-script-backslash +01-script-backslash-space.sh +01-script-backslash-twice.sh 03-echo 03-echo-nesting diff --git a/gash/peg.scm b/gash/peg.scm index 6607109..56e6fb5 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -156,10 +156,10 @@ and <-- '&&' or <-- '||' pipe < '|' + pipeline <-- negate? pipeline-head pipeline-tail* pipeline-head <- sp* command pipeline-tail <- sp* pipe ws* command negate <-- '!' - pipeline <-- negate? pipeline-head pipeline-tail* command <-- (compound-command (sp+ io-redirect)*) / simple-command / function-def compound-command <- brace-group / subshell / for-clause / case-clause / if-clause / while-clause / until-clause simple-command <- (sp* (io-redirect sp+)* nonreserved)+ @@ -212,7 +212,7 @@ filename <-- word name <-- identifier identifier <- [_a-zA-Z][_a-zA-Z0-9]* - word <-- assignment / delim / (number / variable / brace-variable / literal)+ + word <-- assignment / delim / (number / variable / variable-and-or / literal)+ number <-- [0-9]+ lsubst < '$(' @@ -223,9 +223,9 @@ rhs <- (substitution / word)* assign < '=' dollar < '$' - literal <-- (!tick !dollar !pipe !semi !par !nl !sp !rbrace .)+ - variable <-- dollar ('$' / '*' / '?' / '@' / [0-9] / identifier) - brace-variable <- dollar lbrace (variable-or / variable-and / identifier) rbrace + literal <-- backslash? (!ws !tick !dollar !pipe !semi !par !nl !sp !rbrace .)+ + variable <-- dollar ('$' / '*' / '?' / '@' / [0-9] / identifier / lbrace identifier rbrace) + variable-and-or <- dollar lbrace (variable-or / variable-and ) rbrace variable-and <-- identifier plus rhs variable-or <-- identifier minus rhs delim <- singlequotes / doublequotes / substitution @@ -238,6 +238,7 @@ separator <- (sp* break ws*) / ws+ sequential-sep <- (semi !semi ws*) / ws+ amp <- '&' + backslash <- '\\' semi < ';' lpar < '(' rpar < ')' @@ -247,10 +248,14 @@ minus < '-' par < lpar / rpar nl < '\n' - sp < [\t ] + sp < '\t' / ' ' / (escaped-nl sp*) ws < sp / nl + escaped-nl < (backslash nl) error <-- .*") + (when (> %debug-level 1) + (format (current-error-port) "input:~s\n" input)) + (let* ((match (match-pattern script input)) (end (peg:end match)) (pt (peg:tree match))) @@ -340,16 +345,8 @@ s))) (string-split s #\newline)) "\n")) -(define (remove-escaped-newlines s) - (reduce (lambda (next prev) - (let* ((escaped? (string-suffix? "\\" next)) - (next (if escaped? (string-drop-right next 1) next)) - (sep (if escaped? "" "\n"))) - (string-append prev sep next))) - "" (string-split s #\newline))) - (define (parse-string string) - (let* ((pt ((compose parse- remove-escaped-newlines remove-shell-comments) string)) + (let* ((pt ((compose parse- remove-shell-comments) string)) (foo (when (> %debug-level 1) (display "tree:\n") (pretty-print pt))) (flat (flatten pt)) (foo (when (> %debug-level 0) (display "flat:\n") (pretty-print flat))) diff --git a/test/01-exit-0.sh b/test/00-exit-0.sh similarity index 100% rename from test/01-exit-0.sh rename to test/00-exit-0.sh diff --git a/test/02-exit-1.exit b/test/00-exit-1.exit similarity index 100% rename from test/02-exit-1.exit rename to test/00-exit-1.exit diff --git a/test/02-exit-1.sh b/test/00-exit-1.sh similarity index 100% rename from test/02-exit-1.sh rename to test/00-exit-1.sh diff --git a/test/01-script-backslash-space.sh b/test/01-script-backslash-space.sh new file mode 100644 index 0000000..872a36a --- /dev/null +++ b/test/01-script-backslash-space.sh @@ -0,0 +1,4 @@ +echo foo\ + bar baz\ + bla +echo diff --git a/test/01-script-backslash-twice.exit b/test/01-script-backslash-twice.exit new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/test/01-script-backslash-twice.exit @@ -0,0 +1 @@ +2 diff --git a/test/01-script-backslash-twice.sh b/test/01-script-backslash-twice.sh new file mode 100644 index 0000000..d6058cf --- /dev/null +++ b/test/01-script-backslash-twice.sh @@ -0,0 +1,3 @@ +exit \ +\ + 2 diff --git a/test/01-script-backslash.exit b/test/01-script-backslash.exit new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/test/01-script-backslash.exit @@ -0,0 +1 @@ +2 diff --git a/test/01-script-backslash.sh b/test/01-script-backslash.sh new file mode 100644 index 0000000..71cb744 --- /dev/null +++ b/test/01-script-backslash.sh @@ -0,0 +1,2 @@ +exit\ + 2 diff --git a/test/01-script-newline.exit b/test/01-script-newline.exit new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/test/01-script-newline.exit @@ -0,0 +1 @@ +2 diff --git a/test/01-script-newline.sh b/test/01-script-newline.sh new file mode 100644 index 0000000..b8d906f --- /dev/null +++ b/test/01-script-newline.sh @@ -0,0 +1,2 @@ +true +exit 2 diff --git a/test/01-script-semi.exit b/test/01-script-semi.exit new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/test/01-script-semi.exit @@ -0,0 +1 @@ +2 diff --git a/test/01-script-semi.sh b/test/01-script-semi.sh new file mode 100644 index 0000000..41b351d --- /dev/null +++ b/test/01-script-semi.sh @@ -0,0 +1 @@ +true; exit 2 From d13de88e4360009575a635a9b0f71eb044af8954 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 3 Nov 2018 17:33:22 +0100 Subject: [PATCH 197/312] tar: Support --strip-components. * gash/commands/tar.scm (tar): Support --strip-components. * gash/ustar.scm (list-ustar-archive, list-ustar-port, read-ustar-archive, read-ustar-port, read-ustar-file): Likewise. --- gash/commands/tar.scm | 14 +++++++++++--- gash/ustar.scm | 22 ++++++++++++---------- 2 files changed, 23 insertions(+), 13 deletions(-) diff --git a/gash/commands/tar.scm b/gash/commands/tar.scm index 8a1a3d7..2790b9d 100644 --- a/gash/commands/tar.scm +++ b/gash/commands/tar.scm @@ -49,6 +49,8 @@ (numeric-owner?) (owner (value #t)) (sort (value #t)) + (strip (value #t)) + (strip-components (value #t)) (verbose (single-char #\v)) (version (single-char #\V)))) (options (getopt-long args option-spec)) @@ -81,6 +83,10 @@ ((string-suffix? ".xz" file) 'xz) (else #f)))))) (sort-order (and=> (option-ref options 'sort #f) string->symbol)) + (strip (string->number + (or (option-ref options 'strip #f) + (option-ref options 'strip-components #f) + "0"))) (help? (option-ref options 'help #f)) (usage? (and (not help?) (not (or (and create? (pair? files)) extract? list?)))) @@ -99,6 +105,8 @@ Usage: tar [OPTION]... [FILE]... --owner=NAME force NAME as owner for added files --sort=ORDER directory sorting order: none (default), name or inode + --strip-components=NUM strip NUM leading components from file names + names on extraction -t, --list list the contents of an archive -V, --version display version -v, --verbose verbosely list files processed @@ -140,14 +148,14 @@ Usage: tar [OPTION]... [FILE]... (let ((port (if (equal? file "-") (current-input-port) (open-file file "rb")))) (call-with-decompressed-port compression port - (cut read-ustar-port <> files #:verbosity verbosity))) + (cut read-ustar-port <> files #:strip strip #:verbosity verbosity))) (read-ustar-archive file files #:verbosity verbosity))) (list? (if (or compression (equal? file "-")) (let ((port (if (equal? file "-") (current-input-port) (open-file file "rb")))) (call-with-decompressed-port compression port - (cut list-ustar-port <> files #:verbosity (1+ verbosity)))) - (list-ustar-archive file files #:verbosity (1+ verbosity))))))) + (cut list-ustar-port <> files #:strip strip #:verbosity (1+ verbosity)))) + (list-ustar-archive file files #:strip strip #:verbosity (1+ verbosity))))))) (define main tar) diff --git a/gash/ustar.scm b/gash/ustar.scm index 2e613bd..a6285ba 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -459,9 +459,11 @@ (if (string-null? prefix) name (string-append prefix "/" name)))) -(define* (read-ustar-file port header #:key (extract? #t)) +(define* (read-ustar-file port header #:key (extract? #t) (strip 0)) (let* ((size (ustar-header-size header)) (file-name (ustar-header-file-name header)) + (file-name (if (zero? strip) file-name + (string-join (list-tail (string-split file-name #\/) strip) "/"))) (dir (dirname file-name)) (thunk (lambda _ (let loop ((read 0)) @@ -470,7 +472,7 @@ (and record (let* ((read (+ read 512)) (block (if (< read size) record - (sub-bytevector record 0 (- size -512 read))))) + (sub-bytevector record 0 (- size -512 read))))) (when extract? (display (bv->ustar-0string block "block"))) (loop read))))))))) @@ -525,30 +527,30 @@ (apply format #f message args)) (exit 1)))) -(define* (read-ustar-port in files #:key (extract? #t) verbosity) +(define* (read-ustar-port in files #:key (extract? #t) (strip 0) verbosity) (let loop ((header (read-ustar-header in))) (when (and header (not (eof-object? header))) (unless (zero? verbosity) (display-header header #:verbose? (> verbosity 1))) - (read-ustar-file in header #:extract? extract?) + (read-ustar-file in header #:extract? extract? #:strip strip) (loop (read-ustar-header in))))) -(define* (read-ustar-archive file-name files #:key (extract? #t) verbosity) +(define* (read-ustar-archive file-name files #:key (extract? #t) (strip 0) verbosity) (catch #t (lambda _ (call-with-port* (open-file file-name "rb") - (cut read-ustar-port <> files #:extract? extract? #:verbosity verbosity))) + (cut read-ustar-port <> files #:extract? extract? #:strip strip #:verbosity verbosity))) (lambda (key subr message args . rest) (format (current-error-port) "ERROR: ~a\n" (apply format #f message args)) (exit 1)))) -(define* (list-ustar-archive file-name files #:key verbosity) - (read-ustar-archive file-name files #:extract? #f #:verbosity verbosity)) +(define* (list-ustar-archive file-name files #:key (strip 0) verbosity) + (read-ustar-archive file-name files #:extract? #f #:strip strip #:verbosity verbosity)) -(define* (list-ustar-port in files #:key verbosity) - (read-ustar-port in files #:extract? #f #:verbosity verbosity)) +(define* (list-ustar-port in files #:key (strip 0) verbosity) + (read-ustar-port in files #:extract? #f #:strip strip #:verbosity verbosity)) ;;; Local Variables: ;;; mode: scheme From 005061d7127f2decef800b10d2836748327ef7c4 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 3 Nov 2018 18:39:52 +0100 Subject: [PATCH 198/312] tar: Support -C. * gash/commands/tar.scm (tar): Support -C. --- gash/commands/tar.scm | 9 ++++++++- gash/ustar.scm | 3 ++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/gash/commands/tar.scm b/gash/commands/tar.scm index 2790b9d..fff6a8c 100644 --- a/gash/commands/tar.scm +++ b/gash/commands/tar.scm @@ -37,6 +37,7 @@ (let* ((option-spec '((create (single-char #\c)) (compress (single-char #\Z)) + (directory (single-char #\C) (value #t)) (gzip (single-char #\z)) (bzip2 (single-char #\j)) (xz (single-char #\J)) @@ -82,6 +83,7 @@ ((string-suffix? ".gz" file) 'gzip) ((string-suffix? ".xz" file) 'xz) (else #f)))))) + (directory (option-ref options 'directory #f)) (sort-order (and=> (option-ref options 'sort #f) string->symbol)) (strip (string->number (or (option-ref options 'strip #f) @@ -91,11 +93,16 @@ (usage? (and (not help?) (not (or (and create? (pair? files)) extract? list?)))) (verbosity (length (multi-opt options 'verbose))) - (version? (option-ref options 'version #f))) + (version? (option-ref options 'version #f)) + (file (if (or (not directory) (string-prefix? "/" file) (equal? file "-")) file + (string-append (getcwd) "/" file)))) + (when directory + (chdir directory)) (cond (version? (format #t "tar (GASH) ~a\n" %version) (exit 0)) ((or help? usage?) (format (if usage? (current-error-port) #t) "\ Usage: tar [OPTION]... [FILE]... + -C, --directory=DIR change to directory DIR -c, --create create a new archive -f, --file=ARCHIVE use archive file or device ARCHIVE --group=NAME force NAME as group for added files diff --git a/gash/ustar.scm b/gash/ustar.scm index a6285ba..e08086d 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -465,6 +465,7 @@ (file-name (if (zero? strip) file-name (string-join (list-tail (string-split file-name #\/) strip) "/"))) (dir (dirname file-name)) + (extract? (and extract? (not (string-null? file-name)))) (thunk (lambda _ (let loop ((read 0)) (and (< read size) @@ -515,7 +516,7 @@ #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:sort-order sort-order #:verbosity verbosity) files)) -(define* (write-ustar-archive file-name files #:key group mtime numeric-owner? owner verbosity) +(define* (write-ustar-archive file-name files #:key group mtime numeric-owner? owner sort-order verbosity) (catch #t (lambda _ (call-with-port* (open-file file-name "wb") From 63f2d4b5f8dbce70fa6564b9ef365ec97b114e0c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 3 Nov 2018 20:10:23 +0100 Subject: [PATCH 199/312] tar: Support symlinks. * gash/ustar.scm (read-ustar-file): Support symlinks. * gash/shell-utils.scm (display-file): Display them. --- gash/shell-utils.scm | 7 +++++-- gash/ustar.scm | 5 +++-- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/gash/shell-utils.scm b/gash/shell-utils.scm index 34e12d1..ae557fe 100644 --- a/gash/shell-utils.scm +++ b/gash/shell-utils.scm @@ -342,8 +342,11 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." (format #t "~8d" size) (display " ") (display date) - (display " ")) - (display file-name)) + (display " ") + (display file-name) + (when (eq? (stat:type st) 'symlink) + (display " -> ") + (display (readlink file-name))))) (define (multi-opt options name) (let ((opt? (lambda (o) (and (eq? (car o) name) (cdr o))))) diff --git a/gash/ustar.scm b/gash/ustar.scm index e08086d..1c80b0b 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -485,9 +485,10 @@ (if (file-exists? file-name) (delete-file file-name)) (with-output-to-file file-name thunk)) ((directory) (mkdir-p file-name)) - ((symlink) (throw 'todo "symlink"))) + ((symlink) (symlink (ustar-header-link-name header) file-name ))) (thunk)) - (when extract? + (when (and extract? + (not (eq? (ustar-header-type header) 'symlink))) (chmod file-name (ustar-header-mode header)) (let ((mtime (ustar-header-mtime header))) (utime file-name mtime mtime))))) From 8bcc6d3c8219b6a41ea848320757d237d5a3ed3e Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 4 Nov 2018 07:16:16 +0100 Subject: [PATCH 200/312] tar: Extract fix. * gash/ustar.scm (read-ustar-file): Use binary output port. --- gash/ustar.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gash/ustar.scm b/gash/ustar.scm index 1c80b0b..449836c 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -483,7 +483,7 @@ (case (ustar-header-type header) ((regular) (if (file-exists? file-name) (delete-file file-name)) - (with-output-to-file file-name thunk)) + (with-output-to-file file-name thunk #:binary #t)) ((directory) (mkdir-p file-name)) ((symlink) (symlink (ustar-header-link-name header) file-name ))) (thunk)) From 6e396759a3ab1ac67fc836c5dac3c2adb9d20116 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 4 Nov 2018 07:27:59 +0100 Subject: [PATCH 201/312] reboot: Use reboot'. * gash/commands/reboot.scm (reboot'): Rename from reboot. Update users. --- gash/bournish-commands.scm | 2 +- gash/commands/reboot.scm | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 7ceb818..6759fe3 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -77,7 +77,7 @@ (define find-command (wrap-command "find" find)) (define grep-command (wrap-command "grep" grep)) (define ls-command (wrap-command "ls" ls)) -(define reboot-command (wrap-command "reboot" reboot)) +(define reboot-command (wrap-command "reboot" reboot')) (define rm-command (wrap-command "rm" rm)) (define sed-command (wrap-command "sed" sed)) (define tar-command (wrap-command "tar" tar)) diff --git a/gash/commands/reboot.scm b/gash/commands/reboot.scm index 490fe28..b0783ad 100644 --- a/gash/commands/reboot.scm +++ b/gash/commands/reboot.scm @@ -27,10 +27,10 @@ (define-module (gash commands reboot) #:export ( - reboot + reboot' )) -(define (reboot name . args) +(define (reboot' name . args) "Emit code for 'reboot'." ;; Normally Bournish is used in the initrd, where 'reboot' is provided ;; directly by (guile-user). In other cases, just bail out. @@ -41,4 +41,4 @@ "I don't know how to reboot, sorry about that!~%") 1))) -(define main reboot) +(define main reboot') From 678e192b4f76e26c02c5ac0df7135bcf06a0c7f4 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 4 Nov 2018 07:41:16 +0100 Subject: [PATCH 202/312] chmod: Move permission code to shell-utils. * gash/shell-utils.scm (): New record, move from commands/chmod. (parse-modifier, parse-modifiers, make-numeric-chmodifier, apply-chmodifiers): New function, move from commands/chmod. * gash/commands/chmod.scm (chmod): Remove them. * gash/util.scm (char->string, string->string-list): New function. --- gash/builtins.scm | 2 +- gash/commands/chmod.scm | 70 +----------------------------- gash/shell-utils.scm | 94 ++++++++++++++++++++++++++++++++++++++++- gash/util.scm | 27 ++++++++++++ 4 files changed, 122 insertions(+), 71 deletions(-) diff --git a/gash/builtins.scm b/gash/builtins.scm index db08989..1736a27 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -105,7 +105,7 @@ (("+u") (set-shell-opt! "nounset" #f)) (("-x") (set-shell-opt! "xtrace" #t)) (("+x") (set-shell-opt! "xtrace" #f)) - (((and (? string?) arg)) (let* ((lst (map (cut make-string 1 <>) (string->list arg))) + (((and (? string?) arg)) (let* ((lst (string->string-list arg)) (set (car lst))) (when (not (member set '("-" "+"))) (error (format #f "set: no such option:~s\n" args))) diff --git a/gash/commands/chmod.scm b/gash/commands/chmod.scm index c028a8e..5842e2d 100644 --- a/gash/commands/chmod.scm +++ b/gash/commands/chmod.scm @@ -38,74 +38,6 @@ chmod )) -(define-immutable-record-type - (make-chmodifier users operation permissions) - chmodifier? - (users chmodifier-users) - (operation chmodifier-operation) - (permissions chmodifier-permissions)) - -(define (parse-modifier o) - (let* ((c (string->symbol (substring o 0 1))) - (o (if (memq c '(- + =)) (string-append "a" o) o)) - (users (string->symbol (substring o 0 1)))) - (when (not (memq users '(u g o a))) - (error (format #f "chmod: no such user: ~a" users))) - (let ((operation (string->symbol (substring o 1 2)))) - (when (not (memq operation '(- + =))) - (error (format #f "chmod: no such operation: ~a" operation))) - (let* ((perm-string (substring o 2)) - (perm (string->number perm-string 8))) - (if perm (make-numeric-chmodifier perm) - (let ((perms (map char->symbol (string->list perm-string)))) - (make-chmodifier users operation perms))))))) - -(define (char->symbol c) - (string->symbol (make-string 1 c))) - -(define (parse-modifiers o) - (or (and=> (string->number o 8) (compose list (cut make-numeric-chmodifier <>))) - (map parse-modifier (string-split o #\,)))) - -(define (make-numeric-chmodifier o) - (make-chmodifier 'o '= (list o))) - -(define (apply-chmodifiers file modifiers) - (let* ((mode (stat:mode (lstat file))) - (executable? (if (zero? (logand mode #o111)) 0 1))) - (let loop ((modifiers modifiers) (mode mode)) - (if (null? modifiers) ((@ (guile) chmod) file mode) - (loop (cdr modifiers) - (let* ((m (car modifiers)) - (n (chmodifier-numeric-mode m executable?)) - (o (chmodifier-operation m))) - (case o - ((=) n) - ((+) (logior mode n)) - ((-) (logand mode n)) - (else (error (format #f - "chmod: operation not supported: ~s\n" o)))))))))) - -(define (chmodifier-numeric-mode o executable?) - (let* ((permissions (chmodifier-permissions o)) - (users (chmodifier-users o))) - (let loop ((permissions permissions)) - (if (null? permissions) 0 - (+ (let* ((p (car permissions)) - (base (cond ((number? p) p) - ((symbol? p) - (case p - ((r) 4) - ((w) 2) - ((x) 1) - ((X) executable?)))))) - (case users - ((a) (+ base (ash base 3) (ash base 6))) - ((o) base) - ((g) (ash base 3)) - ((u) (ash base 6)))) - (loop (cdr permissions))))))) - (define (chmod . args) (let* ((option-spec '((reference (value #t)) @@ -160,7 +92,7 @@ Each MODE is of the form '[ugoa]*([-+=]([rwxXst]*|[ugo]))+|[-+=][0-7]+'. (m (if executable? (cons (make-chmodifier 'o '- '(x)) m) m)) (m (if xecutable? (cons (make-chmodifier 'o '- '(X)) m) m))) (values m files))) - (else (values (parse-modifiers (car files)) (cdr files)))) + (else (values (parse-chmodifiers (car files)) (cdr files)))) (let ((files (if (option-ref options 'recursive #f) (append-map find-files files) files))) (for-each (cut apply-chmodifiers <> modifiers) files))))))) diff --git a/gash/shell-utils.scm b/gash/shell-utils.scm index ae557fe..ad65612 100644 --- a/gash/shell-utils.scm +++ b/gash/shell-utils.scm @@ -39,6 +39,7 @@ #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) + #:use-module (gash util) #:export ( delete-file-recursively display-tabulated @@ -48,9 +49,21 @@ file-name-predicate find-files file-exists?* + + + make-chmodifier + chmodifier-users + chmodifier-operation + chmodifier-permissions + make-numeric-chmodifier + chmodifier->mode + chmodifiers->mode + apply-chmodifiers + parse-chmodifiers + + grep* grep+ - grep-match-file-name grep-match-string grep-match-line @@ -73,6 +86,7 @@ ;;; This code is taken from (guix build utils) + ;;; ;;; Directories. ;;; @@ -438,3 +452,81 @@ end of a line; by itself it won't match the terminating newline of a line." rx+proc))) (display line out) (loop (read-line in 'concat))))))) + + +;;; +;;; Permissions. +;;; +(define-immutable-record-type + (make-chmodifier users operation permissions) + chmodifier? + (users chmodifier-users) + (operation chmodifier-operation) + (permissions chmodifier-permissions)) + +(define (parse-chmodifier o) + (let* ((c (string->symbol (substring o 0 1))) + (o (if (memq c '(- + =)) (string-append "a" o) o)) + (users (string->symbol (substring o 0 1))) + (program (car (command-line)))) + (when (not (memq users '(u g o a))) + (error (format #f "~a: no such user: ~a" program users))) + (let ((operation (string->symbol (substring o 1 2)))) + (when (not (memq operation '(- + =))) + (error (format #f "~a: no such operation: ~a" program operation))) + (let* ((perm-string (substring o 2)) + (perm (string->number perm-string 8))) + (if perm (make-numeric-chmodifier perm) + (let ((perms (map string->symbol (string->string-list perm-string)))) + (make-chmodifier users operation perms))))))) + +(define (parse-chmodifiers o) + (or (and=> (string->number o 8) (compose list (cut make-numeric-chmodifier <>))) + (map parse-chmodifier (string-split o #\,)))) + +(define (make-numeric-chmodifier o) + (make-chmodifier 'o '= (list o))) + +(define* (chmodifiers->mode modifiers #:optional (mode 0)) + (let loop ((modifiers modifiers) (mode mode)) + (if (null? modifiers) mode + (loop (cdr modifiers) + (chmodifier->mode (car modifiers) mode))))) + +(define* (chmodifier->mode modifier #:optional (mode 0)) + (let* ((executable? (if (zero? (logand mode #o111)) 0 1)) + (n (chmodifier-numeric-mode modifier executable?)) + (o (chmodifier-operation modifier)) + (program (car (command-line)))) + (case o + ((=) n) + ((+) (logior mode n)) + ((-) (logand mode (logxor n -1))) + (else (error + (format #f + "program: operation not supported: ~s\n" + program o)))))) + +(define (apply-chmodifiers file modifiers) + (let ((mode (chmodifiers->mode modifiers (warn 'file-mode(stat:mode (lstat file)))))) + ((@ (guile) chmod) file mode))) + +(define (chmodifier-numeric-mode o executable?) + (let* ((permissions (chmodifier-permissions o)) + (users (chmodifier-users o))) + (let loop ((permissions permissions)) + (if (null? permissions) 0 + (+ (let* ((p (car permissions)) + (base (cond ((number? p) p) + ((symbol? p) + (case p + ((r) 4) + ((w) 2) + ((x) 1) + ((X) executable?)))))) + (case users + ((a) (+ base (ash base 3) (ash base 6))) + ((o) base) + ((g) (ash base 3)) + ((u) (ash base 6)))) + (loop (cdr permissions))))))) diff --git a/gash/util.scm b/gash/util.scm index 08dbac6..2da6d37 100644 --- a/gash/util.scm +++ b/gash/util.scm @@ -1,3 +1,22 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + (define-module (gash util) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -6,6 +25,8 @@ conjoin disjoin wrap-command + char->string + string->string-list )) (define (disjoin . predicates) @@ -15,3 +36,9 @@ (define (conjoin . predicates) (lambda (. arguments) (every (cut apply <> arguments) predicates))) + +(define (string->string-list string) + (map char->string (string->list string))) + +(define (char->string c) + (make-string 1 c)) From f62e6e99a78809b92358ff84e47b8d7e595363c9 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 4 Nov 2018 08:14:05 +0100 Subject: [PATCH 203/312] mkdir: New builtin. * gash/commands/mkdir.scm: New file. * build-aux/build-guile.sh: Compile it. * configure: Create script. * gash/bournish-commands.scm (mkdir-command): New variable. (%bournish-commands): Add it. --- .gitignore | 1 + build-aux/build-guile.sh | 2 ++ configure | 1 + gash/bournish-commands.scm | 2 ++ gash/commands/mkdir.scm | 74 ++++++++++++++++++++++++++++++++++++++ 5 files changed, 80 insertions(+) create mode 100644 gash/commands/mkdir.scm diff --git a/.gitignore b/.gitignore index eb2068c..dcb87c6 100644 --- a/.gitignore +++ b/.gitignore @@ -9,6 +9,7 @@ /bin/gash /bin/grep /bin/ls +/bin/mkdir /bin/reboot /bin/rm /bin/sed diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index ba68bad..0b60054 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -56,6 +56,7 @@ ${srcdest}gash/commands/cp.scm ${srcdest}gash/commands/find.scm ${srcdest}gash/commands/grep.scm ${srcdest}gash/commands/ls.scm +${srcdest}gash/commands/mkdir.scm ${srcdest}gash/commands/reboot.scm ${srcdest}gash/commands/rm.scm ${srcdest}gash/commands/sed.scm @@ -74,6 +75,7 @@ ${srcdest}bin/find ${srcdest}bin/gash ${srcdest}bin/grep ${srcdest}bin/ls +${srcdest}bin/mkdir ${srcdest}bin/reboot ${srcdest}bin/rm ${srcdest}bin/sed diff --git a/configure b/configure index ba601be..891034e 100755 --- a/configure +++ b/configure @@ -96,6 +96,7 @@ cp find grep ls +mkdir reboot rm sed diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 6759fe3..155e1de 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -77,6 +77,7 @@ (define find-command (wrap-command "find" find)) (define grep-command (wrap-command "grep" grep)) (define ls-command (wrap-command "ls" ls)) +(define mkdir-command (wrap-command "mkdir" mkdir)) (define reboot-command (wrap-command "reboot" reboot')) (define rm-command (wrap-command "rm" rm)) (define sed-command (wrap-command "sed" sed)) @@ -92,6 +93,7 @@ ("find" . ,find-command) ("grep" . ,grep-command) ("ls" . ,ls-command) + ("mkdir" . ,mkdir) ("reboot" . ,reboot-command) ("rm" . ,rm-command) ("sed" . ,sed-command) diff --git a/gash/commands/mkdir.scm b/gash/commands/mkdir.scm new file mode 100644 index 0000000..aca721e --- /dev/null +++ b/gash/commands/mkdir.scm @@ -0,0 +1,74 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; Code: + +(define-module (gash commands mkdir) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 regex) + + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) + + #:use-module (gash config) + #:use-module (gash guix-utils) + #:use-module (gash shell-utils) + + #:export ( + mkdir + )) + +(define (mkdir . args) + (let* ((option-spec + '((help (single-char #\h)) + (mode (single-char #\m) (value #t)) + (parents (single-char #\p)) + (version (single-char #\V)))) + (options (getopt-long args option-spec)) + (files (option-ref options '() '())) + (mode (option-ref options 'mode #f)) + (parents? (option-ref options 'parents #f)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '())) + (usage? (and (not help?) (null? files)))) + (cond (version? (format #t "mkdir (GASH) ~a\n" %version) (exit 0)) + ((or help? usage?) (format (if usage? (current-error-port) #t) + "\ +Usage: mkdir [OPTION]... DIRECTORY... +Create the DIRECTORY(ies), if they do not already exist. + +Options: + --help display this help and exit + -m, --mode=MODE set file mode (as in chmod), not a=rwx - umask + -p, --parents no error if existing, make parent directories as needed + --version output version information and exit + +") + (exit (if usage? 2 0))) + (else + (let ((mode (if mode (umask (chmodifiers->mode (parse-modifiers mode))) + #o755))) + (for-each (if parents? mkdir-p (@ (guile) mkdir)) files)))))) + +(define main mkdir) From 45479fc651f7cb48b87e5e1c534c2a7488e9349f Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 4 Nov 2018 08:43:04 +0100 Subject: [PATCH 204/312] rmdir: New builtin. * gash/commands/rmdir.scm: New file. * build-aux/build-guile.sh: Compile it. * configure: Create script. * gash/bournish-commands.scm (rmdir-command): New variable. (%bournish-commands): Add it. * gash/shell-utils.scm (rmdir-p): New function. --- .gitignore | 1 + build-aux/build-guile.sh | 2 ++ configure | 1 + gash/bournish-commands.scm | 2 ++ gash/commands/rmdir.scm | 71 ++++++++++++++++++++++++++++++++++++++ gash/shell-utils.scm | 9 +++++ 6 files changed, 86 insertions(+) create mode 100644 gash/commands/rmdir.scm diff --git a/.gitignore b/.gitignore index dcb87c6..fcf7df3 100644 --- a/.gitignore +++ b/.gitignore @@ -12,6 +12,7 @@ /bin/mkdir /bin/reboot /bin/rm +/bin/rmdir /bin/sed /bin/sh /bin/tar diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 0b60054..60902ae 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -59,6 +59,7 @@ ${srcdest}gash/commands/ls.scm ${srcdest}gash/commands/mkdir.scm ${srcdest}gash/commands/reboot.scm ${srcdest}gash/commands/rm.scm +${srcdest}gash/commands/rmdir.scm ${srcdest}gash/commands/sed.scm ${srcdest}gash/commands/tar.scm ${srcdest}gash/commands/wc.scm @@ -78,6 +79,7 @@ ${srcdest}bin/ls ${srcdest}bin/mkdir ${srcdest}bin/reboot ${srcdest}bin/rm +${srcdest}bin/rmdir ${srcdest}bin/sed ${srcdest}bin/tar ${srcdest}bin/wc diff --git a/configure b/configure index 891034e..33f3478 100755 --- a/configure +++ b/configure @@ -99,6 +99,7 @@ ls mkdir reboot rm +rmdir sed tar wc diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 155e1de..3b56ccd 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -80,6 +80,7 @@ (define mkdir-command (wrap-command "mkdir" mkdir)) (define reboot-command (wrap-command "reboot" reboot')) (define rm-command (wrap-command "rm" rm)) +(define rmdir-command (wrap-command "rmdir" rmdir)) (define sed-command (wrap-command "sed" sed)) (define tar-command (wrap-command "tar" tar)) (define wc-command (wrap-command "wc" wc)) @@ -96,6 +97,7 @@ ("mkdir" . ,mkdir) ("reboot" . ,reboot-command) ("rm" . ,rm-command) + ("rmdir" . ,rmdir-command) ("sed" . ,sed-command) ("tar" . ,tar-command) ("wc" . ,wc-command) diff --git a/gash/commands/rmdir.scm b/gash/commands/rmdir.scm new file mode 100644 index 0000000..3c21de8 --- /dev/null +++ b/gash/commands/rmdir.scm @@ -0,0 +1,71 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; Code: + +(define-module (gash commands rmdir) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 regex) + + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) + + #:use-module (gash config) + #:use-module (gash guix-utils) + #:use-module (gash shell-utils) + + #:export ( + rmdir + )) + +(define (rmdir . args) + (let* ((option-spec + '((help (single-char #\h)) + (parents (single-char #\p)) + (version (single-char #\V)))) + (options (getopt-long args option-spec)) + (files (option-ref options '() '())) + (parents? (option-ref options 'parents #f)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '())) + (usage? (and (not help?) (null? files)))) + (cond (version? (format #t "rmdir (GASH) ~a\n" %version) (exit 0)) + ((or help? usage?) (format (if usage? (current-error-port) #t) + "\ +Usage: rmdir [OPTION]... DIRECTORY... +Remove the DIRECTORY(ies), if they are empty. + +Options: + --help display this help and exit + -p, --parents remove DIRECTORY and its ancestors; e.g., 'rmdir -p a/b/c' is + similar to 'rmdir a/b/c a/b a' + --version output version information and exit + +") + (exit (if usage? 2 0))) + (else + (if parents? (for-each rmdir-p files) + (for-each rmdir files)))))) + +(define main rmdir) diff --git a/gash/shell-utils.scm b/gash/shell-utils.scm index ad65612..6883579 100644 --- a/gash/shell-utils.scm +++ b/gash/shell-utils.scm @@ -70,6 +70,7 @@ grep-match-column grep-match-end-column mkdir-p + rmdir-p multi-opt directory-exists? @@ -270,6 +271,14 @@ transferred and the continuation of the transfer as a thunk." (apply throw args)))))) (() #t)))) +(define (rmdir-p dir) + "Remove directory DIR and all its ancestors." + (rmdir dir) + (let loop ((dir (dirname dir))) + (when (not (equal? dir ".")) + (rmdir dir) + (loop (dirname dir))))) + (define (file-exists?* file) "Like 'file-exists?' but emits a warning if FILE is not accessible." (catch 'system-error From 6250b229512720831ae4bd8c7bf66b7b0ca7886c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 4 Nov 2018 09:29:02 +0100 Subject: [PATCH 205/312] Support && and ||. * gash/script.scm (and-terms, or-terms): New macros. * gash/peg.scm (transform): Transform to use them. (parse-): Parse && and || as binary term operator. * test/20-and.sh: Test it. * test/20-or.sh: Test it. * check.sh (tests): Run it. --- check.sh | 2 ++ gash/peg.scm | 13 +++++++++---- gash/script.scm | 18 ++++++++++++++++++ test/20-and.exit | 1 + test/20-and.sh | 1 + test/20-or.sh | 1 + 6 files changed, 32 insertions(+), 4 deletions(-) create mode 100644 test/20-and.exit create mode 100644 test/20-and.sh create mode 100644 test/20-or.sh diff --git a/check.sh b/check.sh index 0f03704..389ca4b 100755 --- a/check.sh +++ b/check.sh @@ -48,6 +48,8 @@ tests=" 11-for-split-sequence 20-semi.sh +20-or.sh +20-and.sh 20-pipe-exit-0 20-pipe-exit-1 20-pipe-sed diff --git a/gash/peg.scm b/gash/peg.scm index 56e6fb5..413fa2b 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -152,9 +152,9 @@ (define-peg-string-patterns "script <-- ws* (term (separator term)* separator?)? - term <- pipeline (sp* (and / or) ws* pipeline)* - and <-- '&&' - or <-- '||' + term <- (and / or / pipeline) (sp* (and / or /pipeline))* + and <-- pipeline sp* amp-amp ws* pipeline + or <-- pipeline sp* pipe-pipe ws* pipeline pipe < '|' pipeline <-- negate? pipeline-head pipeline-tail* pipeline-head <- sp* command @@ -223,7 +223,7 @@ rhs <- (substitution / word)* assign < '=' dollar < '$' - literal <-- backslash? (!ws !tick !dollar !pipe !semi !par !nl !sp !rbrace .)+ + literal <-- backslash? (!ws !amp !tick !dollar !pipe !semi !par !nl !sp !rbrace .)+ variable <-- dollar ('$' / '*' / '?' / '@' / [0-9] / identifier / lbrace identifier rbrace) variable-and-or <- dollar lbrace (variable-or / variable-and ) rbrace variable-and <-- identifier plus rhs @@ -238,6 +238,8 @@ separator <- (sp* break ws*) / ws+ sequential-sep <- (semi !semi ws*) / ws+ amp <- '&' + amp-amp < '&&' + pipe-pipe < '||' backslash <- '\\' semi < ';' lpar < '(' @@ -326,6 +328,9 @@ (('sequence o ...) `(sequence (quote ,(map transform o)))) + (('and l r) `(and-terms ,(transform l) ,(transform r))) + (('or l r) `(or-terms ,(transform l) ,(transform r))) + (('substitution o) `(substitution ,(transform o))) (('if-clause expr then) `(if-clause ,(transform expr) ,(transform then))) (('if-clause expr then else) `(if-clause ,(transform expr) ,(transform then) ,(transform else))) diff --git a/gash/script.scm b/gash/script.scm index 44a951c..166149b 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -39,6 +39,7 @@ #:use-module (gash util) #:export ( + and-terms background builtin command @@ -48,6 +49,7 @@ if-clause ignore-error literal + or-terms pipeline run script @@ -177,6 +179,22 @@ #'(let ((it (ignore-error expr))) (if (zero? it) then else))))))) +(define-syntax and-terms + (lambda (x) + (syntax-case x () + ((_ left right) + (with-syntax ((it (datum->syntax x 'it))) + #'(let ((it left)) + (if (zero? it) right it))))))) + +(define-syntax or-terms + (lambda (x) + (syntax-case x () + ((_ left right) + (with-syntax ((it (datum->syntax x 'it))) + #'(let ((it (ignore-error left))) + (if (zero? it) it right))))))) + (define (pipeline . commands) (define (handle job) (when (> %debug-level 1) diff --git a/test/20-and.exit b/test/20-and.exit new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/test/20-and.exit @@ -0,0 +1 @@ +2 diff --git a/test/20-and.sh b/test/20-and.sh new file mode 100644 index 0000000..495cfe4 --- /dev/null +++ b/test/20-and.sh @@ -0,0 +1 @@ +true && exit 2 diff --git a/test/20-or.sh b/test/20-or.sh new file mode 100644 index 0000000..84ffdd6 --- /dev/null +++ b/test/20-or.sh @@ -0,0 +1 @@ +false || true From 78989bfb90f0f63059a92329fe2c1dfcda34dbff Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 4 Nov 2018 10:35:11 +0100 Subject: [PATCH 206/312] Fix command tracing. * gash/builtins.scm (term->string): New function. (trace): Use it to make nicer traces; typo: alway display trace. --- gash/builtins.scm | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/gash/builtins.scm b/gash/builtins.scm index 1736a27..1c3073a 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -338,6 +338,14 @@ Options: #f) (apply test-command (drop-right args 1))))))))) +(define (term->string o) + (match o + ((? string?) o) + (('variable name) (variable name)) + (('variable-or name default) (variable-or name default)) + (('variable-and name default) (variable-and name default)) + (_ (format #f "~s" o)))) + (define (trace commands) `(xtrace ,(lambda _ @@ -345,9 +353,11 @@ Options: (for-each (lambda (o) (match o - (('command (and command (? string?)) ...) - (format (current-error-port) "+ ~a\n" (string-join command))) - (_ format (current-error-port) "+ ~s \n" o))) + (('command (and command (or (? string?) ('variable _))) ...) + (format (current-error-port) "+ ~a\n" (string-join (map term->string command)))) + (('command ('assignment name value)) + (format (current-error-port) "+ ~a=~a\n" name (term->string value))) + (_ (format (current-error-port) "+ ~s \n" o)))) (reverse commands)))))) (define %builtin-commands From 478d75bba740b818aa250d2e4139c8575643e9bd Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 4 Nov 2018 11:28:01 +0100 Subject: [PATCH 207/312] touch: New builtin. * gash/commands/touch.scm: New file. * build-aux/build-guile.sh: Compile it. * configure: Create script. * gash/bournish-commands.scm (touch-command): New variable. (%bournish-commands): Add it. --- build-aux/build-guile.sh | 2 + configure | 1 + gash/bournish-commands.scm | 3 ++ gash/commands/chmod.scm | 3 +- gash/commands/touch.scm | 85 ++++++++++++++++++++++++++++++++++++++ 5 files changed, 92 insertions(+), 2 deletions(-) create mode 100644 gash/commands/touch.scm diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 60902ae..358b409 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -62,6 +62,7 @@ ${srcdest}gash/commands/rm.scm ${srcdest}gash/commands/rmdir.scm ${srcdest}gash/commands/sed.scm ${srcdest}gash/commands/tar.scm +${srcdest}gash/commands/touch.scm ${srcdest}gash/commands/wc.scm ${srcdest}gash/commands/which.scm @@ -82,6 +83,7 @@ ${srcdest}bin/rm ${srcdest}bin/rmdir ${srcdest}bin/sed ${srcdest}bin/tar +${srcdest}bin/touch ${srcdest}bin/wc ${srcdest}bin/which " diff --git a/configure b/configure index 33f3478..2ee8c9b 100755 --- a/configure +++ b/configure @@ -102,6 +102,7 @@ rm rmdir sed tar +touch wc which " diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 3b56ccd..9ae0d93 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -41,6 +41,7 @@ #:use-module (gash commands rm) #:use-module (gash commands sed) #:use-module (gash commands tar) + #:use-module (gash commands touch) #:use-module (gash commands wc) #:use-module (gash commands which) @@ -83,6 +84,7 @@ (define rmdir-command (wrap-command "rmdir" rmdir)) (define sed-command (wrap-command "sed" sed)) (define tar-command (wrap-command "tar" tar)) +(define touch-command (wrap-command "touch" touch)) (define wc-command (wrap-command "wc" wc)) (define which-command (wrap-command "which" which)) @@ -100,6 +102,7 @@ ("rmdir" . ,rmdir-command) ("sed" . ,sed-command) ("tar" . ,tar-command) + ("touch" . ,touch-command) ("wc" . ,wc-command) ("which" . ,which-command) )) diff --git a/gash/commands/chmod.scm b/gash/commands/chmod.scm index 5842e2d..6cb2308 100644 --- a/gash/commands/chmod.scm +++ b/gash/commands/chmod.scm @@ -49,7 +49,6 @@ (executable (single-char #\x)) (xecutable (single-char #\X)))) (options (getopt-long args option-spec)) - (files (option-ref options '() '())) (help? (option-ref options 'help #f)) (version? (option-ref options 'version #f)) (files (option-ref options '() '())) @@ -74,7 +73,7 @@ With --reference, change the mode of each FILE to that of RFILE. Options: --help display this help and exit -R, --recursive change files and directories recursively - --reference=RFILE use RFILE's mode instead of MODE values + --reference=FILE use FILE's mode instead of MODE values --version output version information and exit Each MODE is of the form '[ugoa]*([-+=]([rwxXst]*|[ugo]))+|[-+=][0-7]+'. diff --git a/gash/commands/touch.scm b/gash/commands/touch.scm new file mode 100644 index 0000000..bd477bf --- /dev/null +++ b/gash/commands/touch.scm @@ -0,0 +1,85 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; Code: + +(define-module (gash commands touch) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 regex) + + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) + + #:use-module (gash config) + #:use-module (gash guix-utils) + #:use-module (gash shell-utils) + + #:export ( + touch + )) + +(define (create-or-touch file time) + (let ((exists? (file-exists? file))) + (when (not exists?) (with-output-to-file file (cut display ""))) + (cond (time (utime file time time)) + (exists? (let ((time (current-time))) + (utime file time time)))))) + +(define (parse-date string) + (if (string-prefix? "@" string) + (string->number (substring string 1)) + (error (format #f "touch: cannot parse date:~a\n" string)))) + +(define (touch . args) + (let* ((option-spec + '((date (single-char #\d) (value #t)) + (help (single-char #\h)) + (reference (single-char #\r) (value #t)) + (version (single-char #\V)))) + (options (getopt-long args option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (date (option-ref options 'date #f)) + (reference (option-ref options 'reference #f)) + (files (option-ref options '() '())) + (usage? (and (not help?) (null? files)))) + (cond (version? (format #t "touch (GASH) ~a\n" %version) (exit 0)) + ((or help? usage?) (format (if usage? (current-error-port) #t) + "\ +Usage: touch [OPTION]... FILE... +Update the access and modification times of each FILE to the current time. + +Options: + -d, --date=DATE parse DATE and use it instead of current time + --help display this help and exit + -r, --reference=FILE use FILE's times instead of current time + --version output version information and exit + +Each MODE is of the form '[ugoa]*([-+=]([rwxXst]*|[ugo]))+|[-+=][0-7]+'. +") + (exit (if usage? 2 0))) + (else + (let ((time (and=> date parse-date))) + (for-each (cut create-or-touch <> time) files)))))) + +(define main touch) From f2fb1bedc9e32b7848e1345d9445c6afc1a4296b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 4 Nov 2018 16:19:41 +0100 Subject: [PATCH 208/312] tar: Cater for Guix bootstrap-guile's UTF-8 default. * gash/ustar.scm (read-ustar-file): Cater for Guix bootstrap-guile's UTF-8 default. --- gash/ustar.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/gash/ustar.scm b/gash/ustar.scm index 449836c..b8c7bb5 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -467,6 +467,7 @@ (dir (dirname file-name)) (extract? (and extract? (not (string-null? file-name)))) (thunk (lambda _ + (set-port-encoding! (current-output-port) "ISO-8859-1") ; bootstrap-guile uses default UTF-8 (let loop ((read 0)) (and (< read size) (let ((record (read-ustar-record port))) From 9cf3ee9e7e77c49b5e7c83e257abfc30e22063e9 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 4 Nov 2018 14:13:01 +0100 Subject: [PATCH 209/312] WIP > redir --- gash/peg.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gash/peg.scm b/gash/peg.scm index 413fa2b..c8e1cd0 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -160,7 +160,7 @@ pipeline-head <- sp* command pipeline-tail <- sp* pipe ws* command negate <-- '!' - command <-- (compound-command (sp+ io-redirect)*) / simple-command / function-def + command <-- (compound-command (sp+ io-redirect)*) / simple-command (sp+ io-redirect)* / function-def compound-command <- brace-group / subshell / for-clause / case-clause / if-clause / while-clause / until-clause simple-command <- (sp* (io-redirect sp+)* nonreserved)+ nonreserved <- &(reserved word) word / !reserved word @@ -223,7 +223,7 @@ rhs <- (substitution / word)* assign < '=' dollar < '$' - literal <-- backslash? (!ws !amp !tick !dollar !pipe !semi !par !nl !sp !rbrace .)+ + literal <-- backslash? (!ws !amp !tick !dollar !pipe !semi !par !nl !sp !rbrace !io-op .)+ variable <-- dollar ('$' / '*' / '?' / '@' / [0-9] / identifier / lbrace identifier rbrace) variable-and-or <- dollar lbrace (variable-or / variable-and ) rbrace variable-and <-- identifier plus rhs From a8a6ea06df8a9c147f74323ea44b49c682704e07 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 4 Nov 2018 19:33:52 +0100 Subject: [PATCH 210/312] compress WIP --- gash/compress.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/gash/compress.scm b/gash/compress.scm index 63cc931..d2f7e94 100644 --- a/gash/compress.scm +++ b/gash/compress.scm @@ -41,7 +41,7 @@ (define *program-name* "compress (GASH)") (define (_ msg . rest) - (cons msg rest)) + msg) (define (error* status msg . args) (force-output) @@ -79,6 +79,8 @@ (put-bytevector port (u8-list->bytevector (list #x1F #x9D bits)))) (define (compress-port in out bits verbose?) + (set-port-encoding! in "ISO-8859-1") + (set-port-encoding! out "ISO-8859-1") #; (begin (write-lzw-header out bits) @@ -101,7 +103,7 @@ (error* 1 (_ "~a: already exists") outfile)) (let ((in (open-file infile "rb")) (out (open-file outfile "wb"))) - ;; TODO: Keep original files ownership, modes, and access + ;; TODO: Keep original files ownership, modes, and access ;; and modification times. (compress-port in out bits verbose?) (when verbose? @@ -123,6 +125,8 @@ (x #f))) (define (uncompress-port in out verbose?) + (set-port-encoding! in "ISO-8859-1") + (set-port-encoding! out "ISO-8859-1") (let ((bits (read-lzw-header in))) (unless bits (error* 1 (_ "incorrect header"))) From 8d0d50240bc2800504d3fab64f1c4c48993e8c50 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 4 Nov 2018 20:45:40 +0100 Subject: [PATCH 211/312] Support functions. --- check.sh | 4 ++++ gash/environment.scm | 32 +++++++++++++++++++++++++------- gash/peg.scm | 25 +++++++++++++++++-------- gash/script.scm | 16 +++++++++++++++- test/03-echo-doublequotes.sh | 1 + test/03-echo-doublequotes.stdout | 1 + test/60-function.sh | 8 ++++++++ test/60-function.stdout | 4 ++++ test/60-subst.sh | 9 +++++++++ test/data/foo | 3 +++ 10 files changed, 87 insertions(+), 16 deletions(-) create mode 100644 test/03-echo-doublequotes.sh create mode 100644 test/03-echo-doublequotes.stdout create mode 100644 test/60-function.sh create mode 100644 test/60-function.stdout create mode 100644 test/60-subst.sh create mode 100644 test/data/foo diff --git a/check.sh b/check.sh index 389ca4b..44cdfe9 100755 --- a/check.sh +++ b/check.sh @@ -16,6 +16,7 @@ tests=" 01-script-backslash-twice.sh 03-echo +03-echo-doublequotes 03-echo-nesting 03-echo-escaped-doublequotes 03-echo-quoted-doublequotes @@ -65,6 +66,9 @@ tests=" 50-iohere +60-function +60-subst + 100-sed 100-sed-once 100-sed-global diff --git a/gash/environment.scm b/gash/environment.scm index 1f4a329..9121b50 100644 --- a/gash/environment.scm +++ b/gash/environment.scm @@ -24,8 +24,11 @@ #:use-module (gash io) #:export ( + %command-line + %functions %global-variables assignment + function set-shell-opt! shell-opt? variable @@ -33,6 +36,8 @@ variable-or )) +(define %command-line (make-parameter (command-line))) + ;; FIXME: export/env vs set (define %global-variables (map identity ;; FIXME: make mutable @@ -46,6 +51,8 @@ (cons key value))) (environ))))) +(define %functions '()) + (define (assignment name value) (and value (set! %global-variables @@ -53,13 +60,20 @@ #t)) (define* (variable name #:optional (default "")) - (let ((name (if (string-prefix? "$" name) (string-drop name 1) name))) - (or (assoc-ref %global-variables name) - (if (shell-opt? "nounset") (begin - ;; TODO: throw/error - (format (current-error-port) "gash: ~a: unbound variable\n" name) - #f) - default)))) + (cond ((string->number name) + => + (lambda (n) + (if (< n (length (%command-line))) (list-ref (%command-line) n) + ""))) + ((equal? name "#") + (number->string (length (%command-line)))) + (else + (or (assoc-ref %global-variables name) + (if (shell-opt? "nounset") (begin + ;; TODO: throw/error + (format (current-error-port) "gash: ~a: unbound variable\n" name) + #f) + default))))) (define (variable-or name default) (variable name default)) @@ -79,3 +93,7 @@ (define (shell-opt? name) (member name (string-split (assoc-ref %global-variables "SHELLOPTS") #\:))) + +(define (function name body) + (set! %functions + (assoc-set! %functions name body))) diff --git a/gash/peg.scm b/gash/peg.scm index c8e1cd0..db9881e 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -160,14 +160,14 @@ pipeline-head <- sp* command pipeline-tail <- sp* pipe ws* command negate <-- '!' - command <-- (compound-command (sp+ io-redirect)*) / simple-command (sp+ io-redirect)* / function-def + command <-- function / (compound-command (sp+ io-redirect)*) / simple-command (sp+ io-redirect)* compound-command <- brace-group / subshell / for-clause / case-clause / if-clause / while-clause / until-clause simple-command <- (sp* (io-redirect sp+)* nonreserved)+ nonreserved <- &(reserved word) word / !reserved word reserved < 'case' / 'esac' / 'if' / 'fi' / 'then' / 'else' / 'elif' / 'for' / 'done' / 'do' / 'until' / 'while' - function-def <-- name sp* lpar sp* rpar ws* (function-body / error) - function-body <-- compound-command io-redirect* + function <-- identifier sp* lpar sp* rpar ws* (function-body / error) + function-body <- compound-command io-redirect* io-redirect <-- [0-9]* sp* (io-here / io-file) io-file <-- ('<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|') sp* ([0-9]+ / filename) @@ -175,7 +175,7 @@ io-op < '<<-' / '<<' / '<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|' io-suffix <- sp* here-label sp* nl - brace-group <-- '{' (sp* (compound-list / error) sp* '}' / error) + brace-group <-- lbrace (ws* (compound-list / error) ws* rbrace / error) subshell <-- lpar compound-list separator rpar compound-list <- term (separator term)* @@ -212,7 +212,7 @@ filename <-- word name <-- identifier identifier <- [_a-zA-Z][_a-zA-Z0-9]* - word <-- assignment / delim / (number / variable / variable-and-or / literal)+ + word <-- assignment / (delim / number / variable / variable-and-or / literal)+ number <-- [0-9]+ lsubst < '$(' @@ -223,8 +223,8 @@ rhs <- (substitution / word)* assign < '=' dollar < '$' - literal <-- backslash? (!ws !amp !tick !dollar !pipe !semi !par !nl !sp !rbrace !io-op .)+ - variable <-- dollar ('$' / '*' / '?' / '@' / [0-9] / identifier / lbrace identifier rbrace) + literal <-- backslash? (!ws !amp !tick !dollar !pipe !semi !par !nl !sp !rbrace !io-op !dq !sq .)+ + variable <-- dollar ('$' / '#' / '*' / '?' / '@' / [0-9] / identifier / lbrace identifier rbrace) variable-and-or <- dollar lbrace (variable-or / variable-and ) rbrace variable-and <-- identifier plus rhs variable-or <-- identifier minus rhs @@ -233,7 +233,7 @@ dq < [\"] bt < [`] singlequotes <-- sq (doublequotes / (!sq .))* sq - doublequotes <-- dq (singlequotes / substitution / variable / variable-and-or / (!dq .))* dq + doublequotes <-- dq (singlequotes / substitution / number / variable / variable-and-or / literal / (!dq .))* dq break <- amp / semi !semi separator <- (sp* break ws*) / ws+ sequential-sep <- (semi !semi ws*) / ws+ @@ -301,6 +301,9 @@ (('script terms ...) `(script ,@(map transform terms))) + (('pipeline ('command command ('io-redirect ('io-file ">" file-name)))) + (transform `(pipeline (command ,@(transform command)) (lambda _ (with-output-to-file ,(transform file-name) (lambda _ (display (read-string)))))))) + (('pipeline o ...) (let ((commands (map transform o))) `(pipeline ,@(cons (trace commands) commands)))) @@ -339,6 +342,12 @@ (('word 'singlequotes) "") (('word o) (transform o)) (('word o ...) `(string-append ,@(map transform o))) + + (('function name body) + `(function ,name (lambda ( . args) ,(transform body)))) + + (('brace-group o) `(brace-group ,(transform o))) + (('file-name o) `(file-name ,(transform o))) (_ ast))) diff --git a/gash/script.scm b/gash/script.scm index 166149b..763ca6d 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -22,6 +22,7 @@ #:use-module (ice-9 local-eval) #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) + #:use-module (ice-9 rdelim) #:use-module (ice-9 receive) #:use-module (ice-9 regex) @@ -41,9 +42,11 @@ #:export ( and-terms background + brace-group builtin command doublequotes + file-name for glob if-clause @@ -72,6 +75,11 @@ (define (command . args) (define (exec command) (cond ((procedure? command) command) + ((assoc-ref %functions (car command)) + => + (lambda (function) + (parameterize ((%command-line args)) + (last (apply function args))))) ((every string? command) (let* ((program (car command)) (escape-builtin? (and (string? program) (string-prefix? "\\" program))) @@ -155,7 +163,7 @@ (string-join (flatten o) "")) (define-syntax-rule (substitution commands) - (with-output-to-string (lambda _ commands))) + (string-trim-right (with-output-to-string (lambda _ commands)))) (define-syntax-rule (ignore-error o) (let ((errexit (shell-opt? "errexit"))) @@ -271,3 +279,9 @@ (apply command (map (cut local-eval <> (the-environment)) args)) (command)))) (else #f))))) + +(define (brace-group . o) + o) + +(define (file-name o) + o) diff --git a/test/03-echo-doublequotes.sh b/test/03-echo-doublequotes.sh new file mode 100644 index 0000000..9236003 --- /dev/null +++ b/test/03-echo-doublequotes.sh @@ -0,0 +1 @@ +echo "foo" b"ar" diff --git a/test/03-echo-doublequotes.stdout b/test/03-echo-doublequotes.stdout new file mode 100644 index 0000000..d675fa4 --- /dev/null +++ b/test/03-echo-doublequotes.stdout @@ -0,0 +1 @@ +foo bar diff --git a/test/60-function.sh b/test/60-function.sh new file mode 100644 index 0000000..4b0ef4b --- /dev/null +++ b/test/60-function.sh @@ -0,0 +1,8 @@ +foo () { + echo $1 +} + +echo before +foo bar +foo baz +echo after diff --git a/test/60-function.stdout b/test/60-function.stdout new file mode 100644 index 0000000..1de9ad8 --- /dev/null +++ b/test/60-function.stdout @@ -0,0 +1,4 @@ +before +bar +baz +after diff --git a/test/60-subst.sh b/test/60-subst.sh new file mode 100644 index 0000000..8d220d8 --- /dev/null +++ b/test/60-subst.sh @@ -0,0 +1,9 @@ +subst () { + sed \ + -e s",foo,bar,"\ + $1 > $2 +} + +subst test/data/foo foo.tmp +cat foo.tmp +rm foo.tmp diff --git a/test/data/foo b/test/data/foo new file mode 100644 index 0000000..86e041d --- /dev/null +++ b/test/data/foo @@ -0,0 +1,3 @@ +foo +bar +baz From 8f87f7dffaf23b83c22234274de45ce0bc49d20f Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 4 Nov 2018 19:33:57 +0100 Subject: [PATCH 212/312] Support io-here. --- gash/peg.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/gash/peg.scm b/gash/peg.scm index db9881e..a65dcb2 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -170,7 +170,7 @@ function-body <- compound-command io-redirect* io-redirect <-- [0-9]* sp* (io-here / io-file) - io-file <-- ('<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|') sp* ([0-9]+ / filename) + io-file <-- ('<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|') sp* ([0-9]+ / file-name) io-here <- ('<<' / '<<-') io-suffix here-document io-op < '<<-' / '<<' / '<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|' io-suffix <- sp* here-label sp* nl @@ -209,7 +209,7 @@ until-keyword < 'until' until-clause <-- until-keyword ws* compound-list separator do-group - filename <-- word + file-name <-- word name <-- identifier identifier <- [_a-zA-Z][_a-zA-Z0-9]* word <-- assignment / (delim / number / variable / variable-and-or / literal)+ @@ -304,6 +304,9 @@ (('pipeline ('command command ('io-redirect ('io-file ">" file-name)))) (transform `(pipeline (command ,@(transform command)) (lambda _ (with-output-to-file ,(transform file-name) (lambda _ (display (read-string)))))))) + (('pipeline ('command command ('io-redirect "<<" ('here-document here-document)))) + (transform `(pipeline (lambda _ (display ,here-document)) (command ,(transform command))))) + (('pipeline o ...) (let ((commands (map transform o))) `(pipeline ,@(cons (trace commands) commands)))) From e8b56af461676adfa7d892aac186a57f48bea149 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 5 Nov 2018 19:41:43 +0100 Subject: [PATCH 213/312] pipeline: Fix stray outputs. * gash/pipe.scm (pipeline+): Do not add extra newlines, flush. --- gash/pipe.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gash/pipe.scm b/gash/pipe.scm index 0504005..4b7b85c 100644 --- a/gash/pipe.scm +++ b/gash/pipe.scm @@ -115,14 +115,14 @@ (when fg? (let loop ((input ports) (output (list (current-output-port) error-port))) - (let ((line (map read-line input))) + (let ((line (map (cut read-line <> 'concat) input))) (let* ((input-available? (lambda (o ln) (and (not (eof-object? ln)) o))) (line (filter-map input-available? line line)) (output (filter-map input-available? output line)) (input (filter-map input-available? input line))) (when (pair? input) (map display line output) - (map newline output) + (map (cut force-output <>) output) (loop input output))))) (wait job)) (move->fdes error-port 2) From f014281c29465f01c2aed37a8359b121cf9fb677 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 5 Nov 2018 20:24:54 +0100 Subject: [PATCH 214/312] dirname: New builtin. * gash/commands/dirname.scm: New file. * build-aux/build-guile.sh: Compile it. * configure: Create script. * gash/bournish-commands.scm (dirname-command): New variable. (%bournish-commands): Add it. --- .gitignore | 1 + build-aux/build-guile.sh | 2 ++ configure | 1 + gash/bournish-commands.scm | 4 +++ gash/commands/dirname.scm | 71 ++++++++++++++++++++++++++++++++++++++ 5 files changed, 79 insertions(+) create mode 100644 gash/commands/dirname.scm diff --git a/.gitignore b/.gitignore index fcf7df3..4dac3d9 100644 --- a/.gitignore +++ b/.gitignore @@ -5,6 +5,7 @@ /bin/chmod /bin/compress /bin/cp +/bin/dirname /bin/find /bin/gash /bin/grep diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 358b409..4bd7749 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -53,6 +53,7 @@ ${srcdest}gash/commands/cat.scm ${srcdest}gash/commands/chmod.scm ${srcdest}gash/commands/compress.scm ${srcdest}gash/commands/cp.scm +${srcdest}gash/commands/dirname.scm ${srcdest}gash/commands/find.scm ${srcdest}gash/commands/grep.scm ${srcdest}gash/commands/ls.scm @@ -73,6 +74,7 @@ ${srcdest}bin/cat ${srcdest}bin/chmod ${srcdest}bin/compress ${srcdest}bin/cp +${srcdest}bin/dirname ${srcdest}bin/find ${srcdest}bin/gash ${srcdest}bin/grep diff --git a/configure b/configure index 2ee8c9b..b6c3669 100755 --- a/configure +++ b/configure @@ -93,6 +93,7 @@ cat chmod compress cp +dirname find grep ls diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 9ae0d93..a0d8ad4 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -34,6 +34,7 @@ #:use-module (gash commands cat) #:use-module (gash commands compress) #:use-module (gash commands cp) + #:use-module (gash commands dirname) #:use-module (gash commands find) #:use-module (gash commands grep) #:use-module (gash commands ls) @@ -50,6 +51,7 @@ cat-command compress-command cp-command + dirname-command find-command grep-command ls-command @@ -75,6 +77,7 @@ (define cat-command (wrap-command cat "cat")) (define compress-command (wrap-command "compress" compress)) (define cp-command (wrap-command "cp" cp)) +(define dirname-command (wrap-command "dirname" dirname)) (define find-command (wrap-command "find" find)) (define grep-command (wrap-command "grep" grep)) (define ls-command (wrap-command "ls" ls)) @@ -93,6 +96,7 @@ ("cat" . ,cat-command) ("compress" . ,compress-command) ("cp" . ,cp-command) + ("dirname" . ,dirname-command) ("find" . ,find-command) ("grep" . ,grep-command) ("ls" . ,ls-command) diff --git a/gash/commands/dirname.scm b/gash/commands/dirname.scm new file mode 100644 index 0000000..6a61ab8 --- /dev/null +++ b/gash/commands/dirname.scm @@ -0,0 +1,71 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; Code: + +(define-module (gash commands dirname) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 regex) + + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) + + #:use-module (gash config) + #:use-module (gash guix-utils) + #:use-module (gash shell-utils) + + #:export ( + dirname + )) + +(define (dirname . args) + (let* ((option-spec + '((help (single-char #\h)) + (version (single-char #\V)) + (zero (single-char #\z)))) + (options (getopt-long args option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '())) + (zero? (option-ref options 'zero #f)) + (usage? (and (not help?) (null? files)))) + (cond (version? (format #t "dirname (GASH) ~a\n" %version) (exit 0)) + ((or help? usage?) (format (if usage? (current-error-port) #t) + "\ +Usage: dirname [OPTION] FILE... +Output each NAME with its last non-slash component and trailing slashes +removed; if NAME contains no /'s, output '.' (meaning the current directory). + +Options: + --help display this help and exit + --version output version information and exit + -z, --zero end each output line with NUL, not newline +") + (exit (if usage? 2 0))) + (else + (for-each (lambda (file) + (display ((@ (guile) dirname) file)) + (if zero? (display #\nul) (newline))) + files))))) + +(define main dirname) From 1e51c5cbd1c6162fb2fce2115df95bd533388b64 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 5 Nov 2018 20:45:26 +0100 Subject: [PATCH 215/312] basename: New builtin. * gash/commands/basename.scm: New file. * build-aux/build-guile.sh: Compile it. * configure: Create script. * gash/bournish-commands.scm (basename-command): New variable. (%bournish-commands): Add it. --- .gitignore | 1 + build-aux/build-guile.sh | 2 + configure | 1 + gash/bournish-commands.scm | 6 +++ gash/commands/basename.scm | 76 ++++++++++++++++++++++++++++++++++++++ gash/commands/dirname.scm | 13 +------ 6 files changed, 88 insertions(+), 11 deletions(-) create mode 100644 gash/commands/basename.scm diff --git a/.gitignore b/.gitignore index 4dac3d9..53c658d 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,6 @@ *.go *~ +/bin/basename /bin/bash /bin/cat /bin/chmod diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 4bd7749..10529a1 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -49,6 +49,7 @@ ${srcdest}gash/shell-utils.scm ${srcdest}gash/ustar.scm ${srcdest}gash/util.scm +${srcdest}gash/commands/basename.scm ${srcdest}gash/commands/cat.scm ${srcdest}gash/commands/chmod.scm ${srcdest}gash/commands/compress.scm @@ -70,6 +71,7 @@ ${srcdest}gash/commands/which.scm " SCRIPTS=" +${srcdest}bin/basename ${srcdest}bin/cat ${srcdest}bin/chmod ${srcdest}bin/compress diff --git a/configure b/configure index b6c3669..2cef0b8 100755 --- a/configure +++ b/configure @@ -89,6 +89,7 @@ bash sh " BUILTINS=" +basename cat chmod compress diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index a0d8ad4..4a0d089 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -31,6 +31,7 @@ #:use-module (gash config) #:use-module (gash shell-utils) + #:use-module (gash commands basename) #:use-module (gash commands cat) #:use-module (gash commands compress) #:use-module (gash commands cp) @@ -48,6 +49,7 @@ #:export ( %bournish-commands + basename-command cat-command compress-command cp-command @@ -58,6 +60,8 @@ reboot-command rm-command sed-command + tar-command + touch-command rm-command wc-command which-command @@ -74,6 +78,7 @@ ((quit) (car args)) (else 1))))))) +(define basename-command (wrap-command basename "basename")) (define cat-command (wrap-command cat "cat")) (define compress-command (wrap-command "compress" compress)) (define cp-command (wrap-command "cp" cp)) @@ -93,6 +98,7 @@ (define (%bournish-commands) `( + ("basename" . ,basename-command) ("cat" . ,cat-command) ("compress" . ,compress-command) ("cp" . ,cp-command) diff --git a/gash/commands/basename.scm b/gash/commands/basename.scm new file mode 100644 index 0000000..441f5b4 --- /dev/null +++ b/gash/commands/basename.scm @@ -0,0 +1,76 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; Code: + +(define-module (gash commands basename) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 receive) + + #:use-module (gash config) + + #:export ( + basename + )) + +(define (basename . args) + (let* ((option-spec + '((multiple (single-char #\a)) + (help (single-char #\h)) + (version (single-char #\V)) + (suffix (single-char #\s) (value #t)) + (zero (single-char #\z)))) + (options (getopt-long args option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (suffix (option-ref options 'suffix #f)) + (mutliple? (or suffix (option-ref options 'multiple #f))) + (zero? (option-ref options 'zero #f)) + (files (option-ref options '() '())) + (usage? (and (not help?) (null? files)))) + (cond (version? (format #t "basename (GASH) ~a\n" %version) (exit 0)) + ((or help? usage?) (format (if usage? (current-error-port) #t) + "\ +Usage: basename NAME [SUFFIX] + or: basename OPTION... NAME... + +Options: + -a, --multiple support multiple arguments and treat each as a NAME + --help display this help and exit + -s, --suffix=SUFFIX remove a trailing SUFFIX; implies -a + --version output version information and exit + -z, --zero end each output line with NUL, not newline +") + (exit (if usage? 2 0))) + (else + (receive (files suffix) + (if suffix (values files suffix) + (values (list-head files 1) (and (pair? (cdr files)) (cadr files)))) + (for-each (lambda (file) + (let ((file + (if (and (> (string-length file) 1) + (string-suffix? "/" file)) (string-drop-right file 1) + file))) + (if suffix (display ((@ (guile) basename) file suffix)) + (display ((@ (guile) basename) file)))) + (if zero? (display #\nul) (newline))) + files)))))) + +(define main basename) diff --git a/gash/commands/dirname.scm b/gash/commands/dirname.scm index 6a61ab8..567542e 100644 --- a/gash/commands/dirname.scm +++ b/gash/commands/dirname.scm @@ -22,17 +22,8 @@ (define-module (gash commands dirname) #:use-module (ice-9 getopt-long) - #:use-module (ice-9 match) - #:use-module (ice-9 receive) - #:use-module (ice-9 regex) - - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9 gnu) - #:use-module (srfi srfi-26) #:use-module (gash config) - #:use-module (gash guix-utils) - #:use-module (gash shell-utils) #:export ( dirname @@ -52,14 +43,14 @@ (cond (version? (format #t "dirname (GASH) ~a\n" %version) (exit 0)) ((or help? usage?) (format (if usage? (current-error-port) #t) "\ -Usage: dirname [OPTION] FILE... +Usage: dirname [OPTION] NAME... Output each NAME with its last non-slash component and trailing slashes removed; if NAME contains no /'s, output '.' (meaning the current directory). Options: --help display this help and exit --version output version information and exit - -z, --zero end each output line with NUL, not newline + -z, --zero end each output line with NUL, not newline ") (exit (if usage? 2 0))) (else From 8ca428c7f29ea21e9f3f4d2f0c9cff5986855d52 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 5 Nov 2018 22:37:55 +0100 Subject: [PATCH 216/312] Support ${ # ## % %% }. --- check.sh | 6 +++ gash/peg.scm | 17 ++++++--- gash/script.scm | 68 +++++++++++++++++++++++++++++++--- test/70-hash-hash.sh | 2 + test/70-hash-hash.stdout | 1 + test/70-hash.sh | 2 + test/70-hash.stdout | 1 + test/70-percent-percent.sh | 2 + test/70-percent-percent.stdout | 1 + test/70-percent-space.sh | 2 + test/70-percent-space.stdout | 1 + test/70-percent.sh | 2 + test/70-percent.stdout | 1 + 13 files changed, 95 insertions(+), 11 deletions(-) create mode 100644 test/70-hash-hash.sh create mode 100644 test/70-hash-hash.stdout create mode 100644 test/70-hash.sh create mode 100644 test/70-hash.stdout create mode 100644 test/70-percent-percent.sh create mode 100644 test/70-percent-percent.stdout create mode 100644 test/70-percent-space.sh create mode 100644 test/70-percent-space.stdout create mode 100644 test/70-percent.sh create mode 100644 test/70-percent.stdout diff --git a/check.sh b/check.sh index 44cdfe9..d4d9c95 100755 --- a/check.sh +++ b/check.sh @@ -69,6 +69,12 @@ tests=" 60-function 60-subst +70-hash.sh +70-hash-hash.sh +70-percent.sh +70-percent-percent.sh +70-percent-space.sh + 100-sed 100-sed-once 100-sed-global diff --git a/gash/peg.scm b/gash/peg.scm index a65dcb2..603a033 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -225,9 +225,13 @@ dollar < '$' literal <-- backslash? (!ws !amp !tick !dollar !pipe !semi !par !nl !sp !rbrace !io-op !dq !sq .)+ variable <-- dollar ('$' / '#' / '*' / '?' / '@' / [0-9] / identifier / lbrace identifier rbrace) - variable-and-or <- dollar lbrace (variable-or / variable-and ) rbrace + variable-and-or <- dollar lbrace (variable-or / variable-and / variable-hash-hash / variable-hash / variable-percent-percent / variable-percent ) rbrace variable-and <-- identifier plus rhs variable-or <-- identifier minus rhs + variable-hash <-- identifier hash rhs + variable-hash-hash <-- identifier hash hash rhs + variable-percent <-- identifier percent rhs + variable-percent-percent <-- identifier percent percent rhs delim <- singlequotes / doublequotes / substitution sq < ['] dq < [\"] @@ -248,6 +252,8 @@ rbrace < [}] plus < [+] minus < '-' + hash < '#' + percent < '%' par < lpar / rpar nl < '\n' sp < '\t' / ' ' / (escaped-nl sp*) @@ -351,19 +357,20 @@ (('brace-group o) `(brace-group ,(transform o))) (('file-name o) `(file-name ,(transform o))) + (_ ast))) -(define (remove-shell-comments s) +(define (remove-line-comments s) (string-join (map (lambda (s) - (let* ((n (string-index s #\#))) - (if n (string-pad-right s (string-length s) #\space 0 n) + (let ((n (string-index s #\#))) + (if (and n (zero? n)) (string-pad-right s (string-length s) #\space 0 n) s))) (string-split s #\newline)) "\n")) (define (parse-string string) - (let* ((pt ((compose parse- remove-shell-comments) string)) + (let* ((pt ((compose parse- remove-line-comments) string)) (foo (when (> %debug-level 1) (display "tree:\n") (pretty-print pt))) (flat (flatten pt)) (foo (when (> %debug-level 0) (display "flat:\n") (pretty-print flat))) diff --git a/gash/script.scm b/gash/script.scm index 763ca6d..b1859ef 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -91,14 +91,16 @@ (else (lambda () #t)))) (exec (append-map glob args))) -(define (glob pattern) - (define (glob? pattern) - (and (string? pattern) (string-match "\\?|\\*" pattern))) - (define (glob2regex pattern) +(define (glob? pattern) + (and (string? pattern) (string-match "\\?|\\*" pattern))) + +(define* (glob->regex pattern #:key (begin "^") (end "$")) (let* ((pattern (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post)) (pattern (regexp-substitute/global #f "\\?" pattern 'pre "." 'post)) (pattern (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post))) - (make-regexp (string-append "^" pattern "$")))) + (make-regexp (string-append begin pattern end)))) + +(define (glob pattern) (define (glob-match regex path) ;; pattern path -> bool (regexp-match? (regexp-exec regex path))) (define (glob- pattern file-names) @@ -107,7 +109,7 @@ (append-map (lambda (file-name) (map (cut string-append (if (string=? "/" file-name) "" file-name) "/" <>) (filter (conjoin (negate (cut string-prefix? "." <>)) - (cute glob-match (glob2regex pattern) <>)) + (cute glob-match (glob->regex pattern) <>)) (or (scandir file-name) '())))) file-names))) (cond @@ -285,3 +287,57 @@ (define (file-name o) o) + +(define (regexp-exec-non-greedy regexp string) + (let ((max (string-length string))) + (let loop ((size 1)) + (and (<= size max) + (or (regexp-exec regexp (substring string 0 size)) + (loop (1+ size))))))) + +(define (regexp-exec-non-greedy-reverse regexp string) + (let ((max (string-length string))) + (let loop ((start (1- max))) + (and (>= start 0) + (or (regexp-exec regexp (substring string start)) + (loop (1- start))))))) + +(define (variable-hash name pattern) + (let ((value (variable name)) + (glob? (glob? pattern))) + (if glob? (let* ((regexp (glob->regex pattern #:end "")) + (match (regexp-exec-non-greedy regexp value))) + (if match (string-drop value (match:end match)) + value)) + (if (string-prefix? pattern value) (string-drop value (string-length pattern)) + value)))) + +(define (variable-hash-hash name pattern) + (let ((value (variable name)) + (glob? (glob? pattern))) + (if glob? (let* ((regexp (glob->regex pattern #:end "")) + (match (regexp-exec regexp value))) + (if match (string-drop value (match:end match)) + value)) + (if (string-prefix? pattern value) (string-drop value (string-length pattern)) + value)))) + +(define (variable-percent name pattern) + (let ((value (variable name)) + (glob? (glob? pattern))) + (if glob? (let* ((regexp (glob->regex pattern #:begin "")) + (match (regexp-exec-non-greedy-reverse regexp value))) + (if match (substring value 0 (- (string-length value) (match:end match))) + value)) + (if (string-suffix? pattern value) (substring value 0 (string-length pattern)) + value)))) + +(define (variable-percent-percent name pattern) + (let ((value (variable name)) + (glob? (glob? pattern))) + (if glob? (let* ((regexp (glob->regex pattern #:begin "")) + (match (regexp-exec regexp value))) + (if match (substring value 0 (match:start match)) + value)) + (if (string-suffix? pattern value) (substring value 0 (string-length pattern)) + value)))) diff --git a/test/70-hash-hash.sh b/test/70-hash-hash.sh new file mode 100644 index 0000000..bdbec5c --- /dev/null +++ b/test/70-hash-hash.sh @@ -0,0 +1,2 @@ +file=dir/sub/name.ext +echo ${file##*/} diff --git a/test/70-hash-hash.stdout b/test/70-hash-hash.stdout new file mode 100644 index 0000000..a6726fb --- /dev/null +++ b/test/70-hash-hash.stdout @@ -0,0 +1 @@ +name.ext diff --git a/test/70-hash.sh b/test/70-hash.sh new file mode 100644 index 0000000..b4b9c02 --- /dev/null +++ b/test/70-hash.sh @@ -0,0 +1,2 @@ +file=dir/sub/name.ext +echo ${file#*/} diff --git a/test/70-hash.stdout b/test/70-hash.stdout new file mode 100644 index 0000000..2d658b6 --- /dev/null +++ b/test/70-hash.stdout @@ -0,0 +1 @@ +sub/name.ext diff --git a/test/70-percent-percent.sh b/test/70-percent-percent.sh new file mode 100644 index 0000000..47dcc3c --- /dev/null +++ b/test/70-percent-percent.sh @@ -0,0 +1,2 @@ +file=dir/sub/name.ext +echo ${file%%/*} diff --git a/test/70-percent-percent.stdout b/test/70-percent-percent.stdout new file mode 100644 index 0000000..0d2ecd7 --- /dev/null +++ b/test/70-percent-percent.stdout @@ -0,0 +1 @@ +dir diff --git a/test/70-percent-space.sh b/test/70-percent-space.sh new file mode 100644 index 0000000..512072d --- /dev/null +++ b/test/70-percent-space.sh @@ -0,0 +1,2 @@ +args="--prefix=/usr " +echo ${args% *}/ diff --git a/test/70-percent-space.stdout b/test/70-percent-space.stdout new file mode 100644 index 0000000..bc89cc9 --- /dev/null +++ b/test/70-percent-space.stdout @@ -0,0 +1 @@ +--prefix=/usr/ diff --git a/test/70-percent.sh b/test/70-percent.sh new file mode 100644 index 0000000..af50281 --- /dev/null +++ b/test/70-percent.sh @@ -0,0 +1,2 @@ +file=dir/sub/name.ext +echo ${file%/*} diff --git a/test/70-percent.stdout b/test/70-percent.stdout new file mode 100644 index 0000000..86da852 --- /dev/null +++ b/test/70-percent.stdout @@ -0,0 +1 @@ +dir/sub From e8f90ba6a864f03c1995dc44d41bc52f49aac560 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 6 Nov 2018 17:32:39 +0100 Subject: [PATCH 217/312] build: configure. --- configure | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/configure b/configure index 2cef0b8..a8f0c51 100755 --- a/configure +++ b/configure @@ -12,8 +12,8 @@ if [ -z "$PREFIX" ]; then fi BASH=$(command -v bash) -GUILE=$(command -v guile) -GUILE_TOOLS=$(command -v guile-tools) +GUILE=${GUILE-$(command -v guile)} +GUILE_TOOLS=${GUILE_TOOLS-$(command -v guile-tools)} guile_site_dir=$PREFIX/share/guile/site/$guile_effective_version guile_site_ccache_dir=$PREFIX/lib/guile/$guile_effective_version/site-ccache guile_effective_version=$(guile -c '(display (effective-version))') @@ -23,8 +23,7 @@ if [ -d $GEESH_PREFIX ]; then GUILE_LOAD_PATH=$GEESH_PREFIX:$GUILE_LOAD_PATH GUILE_LOAD_COMPILED_PATH=$GEESH_PREFIX:$GUILE_LOAD_COMPILED_PATH if ! $GUILE -c '(use-modules (geesh parser)) (exit (defined? '"'"'read-sh-all))'; then - echo "your geesh is too old" - exit 1 + echo "warning: building without Geesh" fi fi From 726ca052a9d6576cd834fdc2654d92c168fcbfc0 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 10 Nov 2018 10:16:50 +0100 Subject: [PATCH 218/312] Support ${ / / }, ${ / }. --- 70-slash-string-slash.stdout | 1 + check.sh | 19 +++++++++++-------- gash/peg.scm | 6 +++++- gash/script.scm | 18 ++++++++++++++++++ test/70-slash-string-slash.sh | 2 ++ test/70-slash-string.sh | 2 ++ test/70-slash-string.stdout | 1 + test/70-slash.sh | 2 ++ test/70-slash.stdout | 1 + 9 files changed, 43 insertions(+), 9 deletions(-) create mode 100644 70-slash-string-slash.stdout create mode 100644 test/70-slash-string-slash.sh create mode 100644 test/70-slash-string.sh create mode 100644 test/70-slash-string.stdout create mode 100644 test/70-slash.sh create mode 100644 test/70-slash.stdout diff --git a/70-slash-string-slash.stdout b/70-slash-string-slash.stdout new file mode 100644 index 0000000..b5396b5 --- /dev/null +++ b/70-slash-string-slash.stdout @@ -0,0 +1 @@ +xxbar/xx diff --git a/check.sh b/check.sh index d4d9c95..ec54036 100755 --- a/check.sh +++ b/check.sh @@ -12,8 +12,8 @@ tests=" 01-script-newline 01-script-semi 01-script-backslash -01-script-backslash-space.sh -01-script-backslash-twice.sh +01-script-backslash-space +01-script-backslash-twice 03-echo 03-echo-doublequotes @@ -62,18 +62,21 @@ tests=" 40-eval 40-eval-echo-variable -40-assignment-eval-echo.sh +40-assignment-eval-echo 50-iohere 60-function 60-subst -70-hash.sh -70-hash-hash.sh -70-percent.sh -70-percent-percent.sh -70-percent-space.sh +70-hash +70-hash-hash +70-percent +70-percent-percent +70-percent-space +70-slash +70-slash-string +70-slash-string-slash 100-sed 100-sed-once diff --git a/gash/peg.scm b/gash/peg.scm index 603a033..7eac512 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -225,13 +225,16 @@ dollar < '$' literal <-- backslash? (!ws !amp !tick !dollar !pipe !semi !par !nl !sp !rbrace !io-op !dq !sq .)+ variable <-- dollar ('$' / '#' / '*' / '?' / '@' / [0-9] / identifier / lbrace identifier rbrace) - variable-and-or <- dollar lbrace (variable-or / variable-and / variable-hash-hash / variable-hash / variable-percent-percent / variable-percent ) rbrace + variable-and-or <- dollar lbrace (variable-or / variable-and / variable-hash-hash / variable-hash / variable-percent-percent / variable-percent / variable-slash ) rbrace variable-and <-- identifier plus rhs variable-or <-- identifier minus rhs variable-hash <-- identifier hash rhs variable-hash-hash <-- identifier hash hash rhs variable-percent <-- identifier percent rhs variable-percent-percent <-- identifier percent percent rhs + variable-slash <-- (identifier slash pat slash str) / (identifier slash pat slash) / (identifier slash pat) + pat <-- (!dollar !rbrace !slash .)+ + str <-- (!rbrace .)+ delim <- singlequotes / doublequotes / substitution sq < ['] dq < [\"] @@ -254,6 +257,7 @@ minus < '-' hash < '#' percent < '%' + slash < '/' par < lpar / rpar nl < '\n' sp < '\t' / ' ' / (escaped-nl sp*) diff --git a/gash/script.scm b/gash/script.scm index b1859ef..5cda518 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -341,3 +341,21 @@ value)) (if (string-suffix? pattern value) (substring value 0 (string-length pattern)) value)))) + +(define (pat o) + o) + +(define (str o) + o) + +(define* (variable-slash name pattern #:optional (replace "")) + (let ((value (variable name)) + (glob? (glob? pattern))) + (let ((match (if glob? (let ((regexp (glob->regex pattern #:begin "" #:end ""))) + (regexp-exec regexp value)) + (string-match pattern value)))) + (if match (string-append + (substring value 0 (match:start match)) + replace + (substring value (match:end match))) + value)))) diff --git a/test/70-slash-string-slash.sh b/test/70-slash-string-slash.sh new file mode 100644 index 0000000..4b4c961 --- /dev/null +++ b/test/70-slash-string-slash.sh @@ -0,0 +1,2 @@ +var='xxfooxx' +echo "${var/foo/bar/}" diff --git a/test/70-slash-string.sh b/test/70-slash-string.sh new file mode 100644 index 0000000..731949c --- /dev/null +++ b/test/70-slash-string.sh @@ -0,0 +1,2 @@ +var='xxfooxx' +echo "${var/foo/bar}" diff --git a/test/70-slash-string.stdout b/test/70-slash-string.stdout new file mode 100644 index 0000000..354f98b --- /dev/null +++ b/test/70-slash-string.stdout @@ -0,0 +1 @@ +xxbarxx diff --git a/test/70-slash.sh b/test/70-slash.sh new file mode 100644 index 0000000..717a26c --- /dev/null +++ b/test/70-slash.sh @@ -0,0 +1,2 @@ +var='xxfooxx' +echo "${var/foo}" diff --git a/test/70-slash.stdout b/test/70-slash.stdout new file mode 100644 index 0000000..63fc813 --- /dev/null +++ b/test/70-slash.stdout @@ -0,0 +1 @@ +xxxx From 90325b22a2eb7c9cd2333a942aebe6d09f9c99cf Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 10 Nov 2018 10:25:02 +0100 Subject: [PATCH 219/312] Support . script, source script. --- check.sh | 2 ++ gash/peg.scm | 2 ++ gash/script.scm | 11 ++++++++++- test/41-dot.sh | 2 ++ test/data/script.sh | 1 + 5 files changed, 17 insertions(+), 1 deletion(-) create mode 100644 test/41-dot.sh create mode 100644 test/data/script.sh diff --git a/check.sh b/check.sh index ec54036..2eed7f5 100755 --- a/check.sh +++ b/check.sh @@ -64,6 +64,8 @@ tests=" 40-eval-echo-variable 40-assignment-eval-echo +41-dot.sh + 50-iohere 60-function diff --git a/gash/peg.scm b/gash/peg.scm index 7eac512..5d23a4d 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -362,6 +362,8 @@ (('brace-group o) `(brace-group ,(transform o))) (('file-name o) `(file-name ,(transform o))) + ('doublequotes "") + (_ ast))) diff --git a/gash/script.scm b/gash/script.scm index 5cda518..84649d3 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -89,7 +89,13 @@ escape-builtin?)) (lambda _ (status:exit-val (apply system* command)))))) (else (lambda () #t)))) - (exec (append-map glob args))) + (match args + (((or "." "source") file-name) + (let* ((string (with-input-from-file file-name read-string)) + (ast (parse-string string))) + (run ast) + 0)) + (_ (exec (append-map glob args))))) (define (glob? pattern) (and (string? pattern) (string-match "\\?|\\*" pattern))) @@ -342,6 +348,9 @@ (if (string-suffix? pattern value) (substring value 0 (string-length pattern)) value)))) +(define (number o) + o) + (define (pat o) o) diff --git a/test/41-dot.sh b/test/41-dot.sh new file mode 100644 index 0000000..efd157e --- /dev/null +++ b/test/41-dot.sh @@ -0,0 +1,2 @@ +. test/data/script.sh +echo $foo diff --git a/test/data/script.sh b/test/data/script.sh new file mode 100644 index 0000000..74d0a43 --- /dev/null +++ b/test/data/script.sh @@ -0,0 +1 @@ +foo=bar From 9a96816b5db3d24af003575862dcc6db970a943e Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 10 Nov 2018 10:59:08 +0100 Subject: [PATCH 220/312] Support elif. --- check.sh | 5 +++++ gash/peg.scm | 2 ++ test/10-else-multiple.sh | 6 ++++++ test/10-else.multiple.stdout | 2 ++ test/10-if-elif.sh | 8 ++++++++ test/10-if-else.sh | 6 ++++++ test/10-if-multiple.sh | 4 ++++ test/10-if-multiple.stdout | 2 ++ 8 files changed, 35 insertions(+) create mode 100644 test/10-else-multiple.sh create mode 100644 test/10-else.multiple.stdout create mode 100644 test/10-if-elif.sh create mode 100644 test/10-if-else.sh create mode 100644 test/10-if-multiple.sh create mode 100644 test/10-if-multiple.stdout diff --git a/check.sh b/check.sh index 2eed7f5..9d4a401 100755 --- a/check.sh +++ b/check.sh @@ -45,6 +45,11 @@ tests=" 10-if 10-if-false 10-if-word-variable +10-if-multiple +10-if-else +10-else-multiple +10-if-elif + 11-for 11-for-split-sequence diff --git a/gash/peg.scm b/gash/peg.scm index 5d23a4d..7f48363 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -350,6 +350,8 @@ (('substitution o) `(substitution ,(transform o))) (('if-clause expr then) `(if-clause ,(transform expr) ,(transform then))) (('if-clause expr then else) `(if-clause ,(transform expr) ,(transform then) ,(transform else))) + (('elif-part expr then) `(if-clause ,(transform expr) ,(transform then))) + (('elif-part expr then else) `(if-clause ,(transform expr) ,(transform then) ,(transform else))) (('then-part o ...) `(begin ,@(map transform o))) (('else-part o ...) `(begin ,@(map transform o))) (('word 'singlequotes) "") diff --git a/test/10-else-multiple.sh b/test/10-else-multiple.sh new file mode 100644 index 0000000..4e36fb9 --- /dev/null +++ b/test/10-else-multiple.sh @@ -0,0 +1,6 @@ +if false; then + : +else + echo one + echo two +fi diff --git a/test/10-else.multiple.stdout b/test/10-else.multiple.stdout new file mode 100644 index 0000000..814f4a4 --- /dev/null +++ b/test/10-else.multiple.stdout @@ -0,0 +1,2 @@ +one +two diff --git a/test/10-if-elif.sh b/test/10-if-elif.sh new file mode 100644 index 0000000..8ec1e4e --- /dev/null +++ b/test/10-if-elif.sh @@ -0,0 +1,8 @@ +if false; then + exit 1 +elif false; then + exit 2 +else + exit 0 +fi +exit 1 diff --git a/test/10-if-else.sh b/test/10-if-else.sh new file mode 100644 index 0000000..9b34a0b --- /dev/null +++ b/test/10-if-else.sh @@ -0,0 +1,6 @@ +if false; then + exit 1 +else + exit 0 +fi +exit 1 diff --git a/test/10-if-multiple.sh b/test/10-if-multiple.sh new file mode 100644 index 0000000..4f46034 --- /dev/null +++ b/test/10-if-multiple.sh @@ -0,0 +1,4 @@ +if true; then + echo one + echo two +fi diff --git a/test/10-if-multiple.stdout b/test/10-if-multiple.stdout new file mode 100644 index 0000000..814f4a4 --- /dev/null +++ b/test/10-if-multiple.stdout @@ -0,0 +1,2 @@ +one +two From 2ea6d6ce34207dd4b037d79007e2a374d5ed2c6b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 10 Nov 2018 11:45:01 +0100 Subject: [PATCH 221/312] WIP: parse mes configure.sh --- gash/peg.scm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/gash/peg.scm b/gash/peg.scm index 7f48363..33b5f72 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -226,12 +226,12 @@ literal <-- backslash? (!ws !amp !tick !dollar !pipe !semi !par !nl !sp !rbrace !io-op !dq !sq .)+ variable <-- dollar ('$' / '#' / '*' / '?' / '@' / [0-9] / identifier / lbrace identifier rbrace) variable-and-or <- dollar lbrace (variable-or / variable-and / variable-hash-hash / variable-hash / variable-percent-percent / variable-percent / variable-slash ) rbrace - variable-and <-- identifier plus rhs - variable-or <-- identifier minus rhs - variable-hash <-- identifier hash rhs - variable-hash-hash <-- identifier hash hash rhs - variable-percent <-- identifier percent rhs - variable-percent-percent <-- identifier percent percent rhs + variable-and <-- identifier plus (pat / rhs) + variable-or <-- identifier minus (pat / rhs) + variable-hash <-- identifier hash (pat / rhs) + variable-hash-hash <-- identifier hash hash (pat / rhs) + variable-percent <-- identifier percent (pat / rhs) + variable-percent-percent <-- identifier percent percent (pat / rhs) variable-slash <-- (identifier slash pat slash str) / (identifier slash pat slash) / (identifier slash pat) pat <-- (!dollar !rbrace !slash .)+ str <-- (!rbrace .)+ From 5f2bcb952897309064dad83db2e33d70849c6b70 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 10 Nov 2018 11:55:13 +0100 Subject: [PATCH 222/312] test: add failing 07-variable-or-slash.sh. --- 07-variable-or-slash.stdout | 1 + check.sh | 1 + gash/peg.scm | 12 ++++++------ test/07-variable-or-slash.sh | 1 + 4 files changed, 9 insertions(+), 6 deletions(-) create mode 100644 07-variable-or-slash.stdout create mode 100644 test/07-variable-or-slash.sh diff --git a/07-variable-or-slash.stdout b/07-variable-or-slash.stdout new file mode 100644 index 0000000..9787757 --- /dev/null +++ b/07-variable-or-slash.stdout @@ -0,0 +1 @@ +bar/ diff --git a/check.sh b/check.sh index 9d4a401..baeaa38 100755 --- a/check.sh +++ b/check.sh @@ -38,6 +38,7 @@ tests=" 07-variable-or 07-variable-not-or +07-variable-or-slash 08-variable-and 08-variable-not-and diff --git a/gash/peg.scm b/gash/peg.scm index 33b5f72..7b32c35 100644 --- a/gash/peg.scm +++ b/gash/peg.scm @@ -226,12 +226,12 @@ literal <-- backslash? (!ws !amp !tick !dollar !pipe !semi !par !nl !sp !rbrace !io-op !dq !sq .)+ variable <-- dollar ('$' / '#' / '*' / '?' / '@' / [0-9] / identifier / lbrace identifier rbrace) variable-and-or <- dollar lbrace (variable-or / variable-and / variable-hash-hash / variable-hash / variable-percent-percent / variable-percent / variable-slash ) rbrace - variable-and <-- identifier plus (pat / rhs) - variable-or <-- identifier minus (pat / rhs) - variable-hash <-- identifier hash (pat / rhs) - variable-hash-hash <-- identifier hash hash (pat / rhs) - variable-percent <-- identifier percent (pat / rhs) - variable-percent-percent <-- identifier percent percent (pat / rhs) + variable-and <-- identifier plus (pat / rhs / str) + variable-or <-- identifier minus (pat / rhs / str) + variable-hash <-- identifier hash (pat / rhs / str) + variable-hash-hash <-- identifier hash hash (pat / rhs / str) + variable-percent <-- identifier percent (pat / rhs / str) + variable-percent-percent <-- identifier percent percent (pat / rhs /str) variable-slash <-- (identifier slash pat slash str) / (identifier slash pat slash) / (identifier slash pat) pat <-- (!dollar !rbrace !slash .)+ str <-- (!rbrace .)+ diff --git a/test/07-variable-or-slash.sh b/test/07-variable-or-slash.sh new file mode 100644 index 0000000..4ac2f60 --- /dev/null +++ b/test/07-variable-or-slash.sh @@ -0,0 +1 @@ +echo ${foo-bar/} From 1e81a66926dacf95aefaa76d5ce0b666cd3182fb Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 10 Nov 2018 12:07:07 +0100 Subject: [PATCH 223/312] test: 10-if-redirect. --- check.sh | 1 + test/10-if-redirect.sh | 5 +++++ 2 files changed, 6 insertions(+) create mode 100644 test/10-if-redirect.sh diff --git a/check.sh b/check.sh index baeaa38..bd6022a 100755 --- a/check.sh +++ b/check.sh @@ -50,6 +50,7 @@ tests=" 10-if-else 10-else-multiple 10-if-elif +10-if-redirect 11-for 11-for-split-sequence diff --git a/test/10-if-redirect.sh b/test/10-if-redirect.sh new file mode 100644 index 0000000..9b269f6 --- /dev/null +++ b/test/10-if-redirect.sh @@ -0,0 +1,5 @@ +if $SHELL --version | grep foobar 2>/dev/null; then + exit 1 +else + exit 0 +fi From 2334e6ebde18a4ee96daff789c16156a3e11e995 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Sat, 3 Nov 2018 11:54:20 +0100 Subject: [PATCH 224/312] revamp PEG grammar --- gash/gash.scm | 5 +- gash/grammar.scm | 249 ++++++++++++++++++++++++++ gash/peg.scm | 395 ------------------------------------------ peg.scm | 41 +++++ peg/cache.scm | 45 +++++ peg/codegen.scm | 390 +++++++++++++++++++++++++++++++++++++++++ peg/simplify-tree.scm | 97 +++++++++++ peg/string-peg.scm | 280 ++++++++++++++++++++++++++++++ peg/using-parsers.scm | 116 +++++++++++++ 9 files changed, 1220 insertions(+), 398 deletions(-) create mode 100644 gash/grammar.scm delete mode 100644 gash/peg.scm create mode 100644 peg.scm create mode 100644 peg/cache.scm create mode 100644 peg/codegen.scm create mode 100644 peg/simplify-tree.scm create mode 100644 peg/string-peg.scm create mode 100644 peg/using-parsers.scm diff --git a/gash/gash.scm b/gash/gash.scm index b3a6cd1..f5925e6 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -8,7 +8,6 @@ #:use-module (ice-9 getopt-long) #:use-module (ice-9 local-eval) #:use-module (ice-9 match) - #:use-module (ice-9 rdelim) #:use-module (ice-9 pretty-print) #:use-module (ice-9 receive) #:use-module (ice-9 regex) @@ -40,12 +39,12 @@ (define (parse-string string) (let ((parser (cond (%geesh-parser? (@ (gash geesh) parse-string)) - (else (@ (gash peg) parse-string))))) + (else (@ (gash grammar) parse-string))))) (parser string))) (define (parse port) (let ((parser (cond (%geesh-parser? (@ (gash geesh) parse)) - (else (@ (gash peg) parse))))) + (else (@ (gash grammar) parse))))) (parser port))) (define (file-to-ast file-name) diff --git a/gash/grammar.scm b/gash/grammar.scm new file mode 100644 index 0000000..ae1c0ee --- /dev/null +++ b/gash/grammar.scm @@ -0,0 +1,249 @@ +(define-module (gash grammar) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 rdelim) + + #:use-module (srfi srfi-8) + + #:use-module (peg) + #:use-module (peg codegen) + + #:export (parse + parse-string)) + +;; (define-syntax define-unwrapped-sexp-parser +;; (lambda (x) +;; (syntax-case x () +;; ((_ sym accum pat) +;; (let* ((matchf (compile-peg-pattern #'pat (syntax->datum #'accum)))) +;; #`(define sym #,matchf)))))) + +;; (define-unwrapped-sexp-parser eol none (or "\f" "\n" "\r")) +;; (add-peg-compiler! 'eol eol) + +;; (define-unwrapped-sexp-parser ws none (or " " "\t" "\v")) +;; (add-peg-compiler! 'ws ws) + +;; (define-unwrapped-sexp-parser line none (and "#" (* (and (not-followed-by eol) peg-any)))) +;; (add-peg-compiler! 'line line) + +;; (define-unwrapped-sexp-parser skip none (* (or ws eol line))) +;; (add-peg-compiler! 'skip skip) + +;; (define (wrap-skip-parser-for-users for-syntax parser accumsym s-syn) +;; (display "wrap\n") +;; #`(lambda (str strlen pos) +;; (when #t +;; (format (current-error-port) "~a ~a : ~s\n" +;; (make-string (- pos (or (string-rindex str #\newline 0 pos) 0)) #\space) +;; '#,s-syn +;; (substring str pos (min (+ pos 40) strlen)))) + +;; (let* ((res (skip str strlen pos)) +;; (pos (or (and res (car res)) pos)) +;; (res (#,parser str strlen pos))) +;; ;; Try to match the nonterminal. +;; (if res +;; ;; If we matched, do some post-processing to figure out +;; ;; what data to propagate upward. +;; (let* ((at (car res)) +;; (body (cadr res))) +;; #,(cond +;; ((eq? accumsym 'name) +;; #``(,at ,'#,s-syn)) +;; ((eq? accumsym 'all) +;; #`(list at +;; (cond +;; ((not (list? body)) +;; `(,'#,s-syn ,body)) +;; ((null? body) `(,'#,s-syn)) +;; ((symbol? (car body)) +;; `(,'#,s-syn ,body)) +;; (else (cons '#,s-syn body))))) +;; ((eq? accumsym 'none) #``(,at ())) +;; (else #``(,at ,body)))) +;; ;; If we didn't match, just return false. +;; #f)))) + +;; (module-set! (resolve-module '(peg codegen)) 'wrap-parser-for-users wrap-skip-parser-for-users) + +(define (parse port) + (parse-string (read-string port))) + +(define (parse-string input) + + (define io-label "") + + (define (io-label-name str len pos) + (let ((at (string-skip str char-alphabetic? pos len))) + (set! io-label (substring str pos at)) + (if (< at len) (list at '()) + #f))) + + (define (io-label-match str len pos) + (if (string-prefix? io-label (substring str pos)) + (list (+ pos (string-length io-label)) '()) + #f)) + + (define-peg-pattern io-here-label none io-label-name) + (define-peg-pattern io-here-delim none io-label-match) + (define-peg-pattern io-here-document all + (and (+ (and (not-followed-by io-here-delim) + peg-any)) + io-here-delim)) + + (define-peg-string-patterns + "script <-- ws* compound + ws < sp / eol + sp < '\\\n'? (comment / [ \t\v]) + comment < [#] (!eol .)* + eol < [\n\r\f] + + compound <-- (term (&rpar / sep#))* + + sep <- sp* (amp ws* / semi ws* / eof) / ws+ + amp <- '&' + semi < ';'!';' + eof < !. + + term <- and / or / pipeline + and <-- pipeline and-op ws* term + or <-- pipeline or-op ws* term + and-op < '&&' + or-op < '||' + + pipeline <-- '!'? sp* (command (&sep / &or-op / &and-op / &rpar / eof / pipe#))+ + + and-or <- '&&' / '||' + + exclamation <- '!' + pipe < sp* '|' !'|' ws* + + command <-- function-def / compound-command / simple-command + + compound-command <- (subshell / brace-group / for-clause / case-clause / + if-clause / while-clause / until-clause) (sp* io-redirect)* + + simple-command <- ((io-redirect / nonreserved) sp*)+ + io-redirect <-- [0-9]* (io-here / io-file) + io-file <-- io-op ([0-9]+ / word) + io-op <- '<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|' + io-here <-- io-here-op io-here-label sp* eol io-here-document + io-here-op <- '<<-' / '<<' + + function-def <-- name sp* lpar rpar# ws* function-body + name <-- !reserved identifier + function-body <-- brace-group (sp* io-redirect)* + + subshell <-- lpar compound rpar# + brace-group <-- lbrace ws* compound rbrace# + + case-clause <-- 'case' sp* word sp* 'in'# ws* case-item+ ws* 'esac'# + case-item <-- pattern sp* colon? ws* compound? case-sep? + colon < ':' + case-sep < ';;' ws* + pattern <-- (word (!rpar '|'# / !'|' &rpar))+ rpar# + + for-clause <-- 'for' sp+ identifier ws+ ('in' sp+ expression)? sep# do-group + expression <-- command + do-group <-- 'do' ws+ compound 'done'# + + if-clause <-- 'if' sp+ compound 'then'# ws+ compound else-part? 'fi'# + else-part <-- 'else' ws+ compound / + 'elif' ws+ compound 'then'# ws+ compound else-part? + + while-clause <-- 'while' compound do-group + + until-clause <-- 'until' compound do-group + + reserved < ('case' / 'esac' / 'in' / 'if' / 'fi' / 'then' / 'else' / + 'elif' / 'for' / 'done' / 'do' / 'until' / 'while') &ws + + nonreserved <- !reserved word + + word <-- test / substitution / assignment / number / variable / + delim / literal + + test <-- ltest sp+ (word sp+)+ rtest# + ltest < '[' + rtest < ']' + + literal <- !reserved (!']' ![ \t\v\f\n`'\")};|&\\] .)+ + + identifier <- [_a-zA-Z][_a-zA-Z0-9]* + + dollar < '$' + number <-- [0-9]+ + + substitution <-- dollar lpar compound rpar# / bt ([\\] bt / !bt .)+ bt# + lpar < '(' + rpar < ')' + bt < [`] + + assignment <-- name assign word? + assign < '=' + + variable <-- dollar ('*' / '@' / [0-9] / name / + lbrace name (variable-or / variable-and / variable-word / variable-literal / &rbrace) rbrace) + variable-or <-- min variable-word + variable-and <-- plus variable-word + variable-word <- (variable-regex / substitution / variable / variable-literal)+ + variable-regex <-- ('%%' / '%' / '##' / '#' / '^^' / '^' /',,' / ',' / '*' / '@' / '?')+ variable-word + variable-literal <- (!rbrace .)+ + min < '-' + plus < '+' + lbrace < '{' + rbrace < '}' + + + delim <-- singlequotes / doublequotes / substitution + sq < ['] + dq < [\"] + singlequotes <- sq (!['] .)* sq# + doublequotes <- dq (substitution / variable / (![\"] .))* dq#") + + (catch 'syntax-error + (lambda () + (let* ((match (match-pattern script input)) + (end (peg:end match)) + (tree (peg:tree match))) + (if (eq? (string-length input) end) + tree + (if match + (begin + (format (current-error-port) "parse error: at offset: ~a\n" end) + (pretty-print tree) + #f) + (begin + (format (current-error-port) "parse error: no match\n") + #f))))) + (lambda (key . args) + (define (line-column input pos) + (let ((length (string-length input))) + (let loop ((lines (string-split input #\newline)) (ln 1) (p 0)) + (if (null? lines) (values #f #f input) + (let* ((line (car lines)) + (length (string-length line)) + (end (+ p length 1)) + (last? (null? (cdr lines)))) + (if (<= pos end) (values ln (+ (if last? 0 1) (- pos p)) + (if last? line + (string-append line "\\n" (cadr lines)))) + (loop (cdr lines) (1+ ln) end))))))) + (define (format-peg o) + (match o + (('or l ...) (string-join (map format-peg l) ", or ")) + (('and l ...) (string-join (map format-peg l) " ")) + ((? symbol?) (symbol->string o)) + ((? string?) o))) + + (receive (ln col line) (line-column input (caar args)) + (let* ((col (- col 1)) + (indent (make-string col #\space))) + (format #t "~a:~a:~a: syntax-error:\n~a\n~a^\n~aexpected: ~a\n" + "" + ln col line + indent + indent + (format-peg (cadar args))) + (exit 1)))))) diff --git a/gash/peg.scm b/gash/peg.scm deleted file mode 100644 index 7b32c35..0000000 --- a/gash/peg.scm +++ /dev/null @@ -1,395 +0,0 @@ -(define-module (gash peg) - #:use-module (ice-9 local-eval) - #:use-module (ice-9 match) - #:use-module (ice-9 pretty-print) - #:use-module (ice-9 peg) - #:use-module (ice-9 peg codegen) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 regex) - - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - - #:use-module (gash builtins) - #:use-module (gash environment) - #:use-module (gash gash) - #:use-module (gash io) - #:use-module (gash script) - - #:export ( - parse - parse-string - peg-trace? - )) - -(define (wrap-parser-for-users for-syntax parser accumsym s-syn) - #`(lambda (str strlen pos) - (when (> (@ (gash gash) %debug-level) 2) - (format (current-error-port) "~a ~a : ~s\n" - (make-string (- pos (or (string-rindex str #\newline 0 pos) 0)) #\space) - '#,s-syn - (substring str pos (min (+ pos 40) strlen)))) - - (let* ((res (#,parser str strlen pos))) - ;; Try to match the nonterminal. - (if res - ;; If we matched, do some post-processing to figure out - ;; what data to propagate upward. - (let ((at (car res)) - (body (cadr res))) - #,(cond - ((eq? accumsym 'name) - #`(list at '#,s-syn)) - ((eq? accumsym 'all) - #`(list (car res) - (cond - ((not (list? body)) - (list '#,s-syn body)) - ((null? body) '#,s-syn) - ((symbol? (car body)) - (list '#,s-syn body)) - (else (cons '#,s-syn body))))) - ((eq? accumsym 'none) #`(list (car res) '())) - (else #`(begin res)))) - ;; If we didn't match, just return false. - #f)))) - -(module-define! (resolve-module '(ice-9 peg codegen)) - 'wrap-parser-for-users - wrap-parser-for-users) - -(define (error? x) - (let loop ((x x)) - (if (null? x) #f - (if (not (pair? x)) - (eq? 'error x) - (or (loop (car x)) - (loop (cdr x))))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;; WIP -(define (expand identifier o) ;;identifier-string -> symbol - (define (expand- o) - (let ((dollar-identifier (string-append "$" identifier))) - (match o - ((? symbol?) o) - ((? string?) (if (string=? o dollar-identifier) (string->symbol identifier) o)) - ((? list?) (map expand- o)) - (_ o)))) - (map expand- o)) - -(define (tostring . args) - (with-output-to-string (cut map display args))) - -;; transform ast -> list of expr -;; such that (map eval expr) -(define (DEAD-transform ast) - (format (current-error-port) "transform=~s\n" ast) - (match ast - (('script term "&") (list (background (transform term)))) - (('script term) `(,(transform term))) - (('script terms ...) (transform terms)) - (('substitution "$(" script ")") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment))) - (('substitution "`" script "`") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment))) - ((('term command)) `(,(transform command))) - ((('term command) ...) (map transform command)) - ((('term command) (('term commands) ...)) (map transform (cons command commands))) - (('compound-list terms ...) (transform terms)) - (('if-clause "if" (expression "then" consequent "fi")) - `(if (equal? 0 (status:exit-val ,@(transform expression))) - (begin ,@(transform consequent)))) - (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) - `(if (equal? 0 (status:exit-val ,@(transform expression))) - (begin ,@(transform consequent)) - (begin ,@(transform alternative)))) - (('for-clause ("for" identifier sep do-group)) #t) - (('for-clause "for" ((identifier "in" lst sep) do-group)) - `(for-each (lambda (,(string->symbol identifier)) - (begin ,@(expand identifier (transform do-group)))) - (glob ,(transform lst)))) - (('do-group "do" (command "done")) (transform command)) - (('pipeline command) (pk 1) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,@command)))) - (('pipeline command piped-commands) (pk 2) `(pipeline #t ,@(transform command) ,@(transform piped-commands))) - (('simple-command ('word (assignment name value))) `((lambda _ (let ((name ,(tostring (transform name))) - (value ,(tostring (transform value)))) - (stderr "assignment: " name "=" value) - (set! global-variables (assoc-set! global-variables name (glob value))))))) - (('simple-command ('word s)) `((glob ,(transform s)))) - (('simple-command ('word s1) ('io-redirect "<<" ('here-document s2))) `((append (glob "echo") (cons "-n" (glob ,s2))) (glob ,(transform s1)))) - (('simple-command ('word s1) ('word s2)) `((append (glob ,(transform s1)) (glob ,(transform s2))))) - (('simple-command ('word s1) (('word s2) ...)) `((append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2)))))) - (('variable s) s) - (('literal s) (transform s)) - (('singlequotes s) (string-concatenate `("'" ,s "'"))) - (('doublequotes s) (string-concatenate `("\"" ,s "\""))) - (('backticks s) (string-concatenate `("`" ,s "`"))) - (('delim ('singlequotes s ...)) (string-concatenate (map transform s))) - (('delim ('doublequotes s ...)) (string-concatenate (map transform s))) - (('delim ('backticks s ...)) (string-concatenate (map transform s))) - ((('pipe _) command) (transform command)) - (((('pipe _) command) ...) (map (compose car transform) command)) - ((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...) - (_ ast))) ;; done - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(define (parse- input) - (define label "") - (define (label-name str len pos) - (let ((at (string-skip str char-alphabetic? pos len))) - (set! label (substring str pos at)) - (if (< at len) (list at '()) - #f))) - - (define (label-match str len pos) - (if (string-prefix? label (substring str pos)) (list (+ pos (string-length label)) '()) - #f)) - - (define-peg-pattern here-label none label-name) - (define-peg-pattern here-delim none label-match) - (define-peg-pattern here-document all (and (+ (and (not-followed-by here-delim) peg-any)) here-delim)) - - (define-peg-string-patterns - "script <-- ws* (term (separator term)* separator?)? - term <- (and / or / pipeline) (sp* (and / or /pipeline))* - and <-- pipeline sp* amp-amp ws* pipeline - or <-- pipeline sp* pipe-pipe ws* pipeline - pipe < '|' - pipeline <-- negate? pipeline-head pipeline-tail* - pipeline-head <- sp* command - pipeline-tail <- sp* pipe ws* command - negate <-- '!' - command <-- function / (compound-command (sp+ io-redirect)*) / simple-command (sp+ io-redirect)* - compound-command <- brace-group / subshell / for-clause / case-clause / if-clause / while-clause / until-clause - simple-command <- (sp* (io-redirect sp+)* nonreserved)+ - nonreserved <- &(reserved word) word / !reserved word - reserved < 'case' / 'esac' / 'if' / 'fi' / 'then' / 'else' / 'elif' / 'for' / 'done' / 'do' / 'until' / 'while' - - function <-- identifier sp* lpar sp* rpar ws* (function-body / error) - function-body <- compound-command io-redirect* - - io-redirect <-- [0-9]* sp* (io-here / io-file) - io-file <-- ('<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|') sp* ([0-9]+ / file-name) - io-here <- ('<<' / '<<-') io-suffix here-document - io-op < '<<-' / '<<' / '<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|' - io-suffix <- sp* here-label sp* nl - - brace-group <-- lbrace (ws* (compound-list / error) ws* rbrace / error) - subshell <-- lpar compound-list separator rpar - compound-list <- term (separator term)* - - case-keyword < 'case' - case-clause <-- case-keyword sp+ word ws+ 'in' ws+ case-item* 'esac' - case-item <-- pattern ((compound-list separator)? case-sep ws* / error) - case-sep < ';;' - pattern <-- sp* word (sp* '|' sp* word)* sp* ')' sp* - - for-keyword < 'for' - in-keyword < 'in' - for-clause <-- for-keyword sp+ name (ws+ in-keyword sequence)? sp* sequential-sep do-group - sequence <-- (sp+ word)+ - do-keyword < 'do' - done-keyword < 'done' - do-group <- do-keyword ws* compound-list separator done-keyword - - if-keyword < 'if' - fi-keyword < 'fi' - if-clause <-- if-keyword pipeline separator then-part elif-part* else-part? fi-keyword - then-keyword < 'then' - then-part <-- then-keyword ws* compound-list separator - elif-keyword < 'elif' - elif-part <-- elif-keyword ws* compound-list separator then-keyword ws* compound-list separator else-part? - else-keyword < 'else' - else-part <-- else-keyword ws* compound-list separator - - while-keyword < 'while' - while-clause <-- while-keyword ws* compound-list separator do-group - - until-keyword < 'until' - until-clause <-- until-keyword ws* compound-list separator do-group - - file-name <-- word - name <-- identifier - identifier <- [_a-zA-Z][_a-zA-Z0-9]* - word <-- assignment / (delim / number / variable / variable-and-or / literal)+ - - number <-- [0-9]+ - lsubst < '$(' - rsubst < ')' - tick < '`' - substitution <-- lsubst script rsubst / tick script tick - assignment <-- name assign rhs - rhs <- (substitution / word)* - assign < '=' - dollar < '$' - literal <-- backslash? (!ws !amp !tick !dollar !pipe !semi !par !nl !sp !rbrace !io-op !dq !sq .)+ - variable <-- dollar ('$' / '#' / '*' / '?' / '@' / [0-9] / identifier / lbrace identifier rbrace) - variable-and-or <- dollar lbrace (variable-or / variable-and / variable-hash-hash / variable-hash / variable-percent-percent / variable-percent / variable-slash ) rbrace - variable-and <-- identifier plus (pat / rhs / str) - variable-or <-- identifier minus (pat / rhs / str) - variable-hash <-- identifier hash (pat / rhs / str) - variable-hash-hash <-- identifier hash hash (pat / rhs / str) - variable-percent <-- identifier percent (pat / rhs / str) - variable-percent-percent <-- identifier percent percent (pat / rhs /str) - variable-slash <-- (identifier slash pat slash str) / (identifier slash pat slash) / (identifier slash pat) - pat <-- (!dollar !rbrace !slash .)+ - str <-- (!rbrace .)+ - delim <- singlequotes / doublequotes / substitution - sq < ['] - dq < [\"] - bt < [`] - singlequotes <-- sq (doublequotes / (!sq .))* sq - doublequotes <-- dq (singlequotes / substitution / number / variable / variable-and-or / literal / (!dq .))* dq - break <- amp / semi !semi - separator <- (sp* break ws*) / ws+ - sequential-sep <- (semi !semi ws*) / ws+ - amp <- '&' - amp-amp < '&&' - pipe-pipe < '||' - backslash <- '\\' - semi < ';' - lpar < '(' - rpar < ')' - lbrace < [{] - rbrace < [}] - plus < [+] - minus < '-' - hash < '#' - percent < '%' - slash < '/' - par < lpar / rpar - nl < '\n' - sp < '\t' / ' ' / (escaped-nl sp*) - ws < sp / nl - escaped-nl < (backslash nl) - error <-- .*") - - (when (> %debug-level 1) - (format (current-error-port) "input:~s\n" input)) - - (let* ((match (match-pattern script input)) - (end (peg:end match)) - (pt (peg:tree match))) - (if (eq? (string-length input) end) - pt - (if match - (begin - (format (current-error-port) "parse error: at offset: ~a\n" end) - (pretty-print pt (current-error-port)) - #f) - (begin - (format (current-error-port) "parse error: no match\n") - #f))))) - -(define (flatten o) - (keyword-flatten '(and assignent command doublequotes for-clause literal name or pipeline singlequotes substitution word) o)) - -(define (unspecified? o) - (eq? o *unspecified*)) - -(define (transform ast) - (when (> %debug-level 1) - (pretty-print ast (current-error-port))) - (match ast - ;; FIXME: flatten? - - ((('assignent _ ...) _ ...) (map transform (flatten ast))) - ((('command _ ...) _ ...) (map transform (flatten ast))) - ((('doublequotes _ ...) _ ...) (map transform (flatten ast))) - ((('for-clause _ ...) _ ...) (map transform (flatten ast))) - ((('literal _ ...) _ ...) (map transform (flatten ast))) - ((('pipeline _ ...) _ ...) (map transform (flatten ast))) - ((('singlequotes _ ...) _ ...) (map transform (flatten ast))) - - ((('word _ ...) ('word _ ...)) (transform (cons 'word ast))) - - ((('word _ ...) _ ...) (map transform (flatten ast))) - - (('script ('pipeline ('command command ... (word (literal "&"))))) - (background `(pipeline ',(map transform command)))) - - (('script terms ...) `(script ,@(map transform terms))) - - (('pipeline ('command command ('io-redirect ('io-file ">" file-name)))) - (transform `(pipeline (command ,@(transform command)) (lambda _ (with-output-to-file ,(transform file-name) (lambda _ (display (read-string)))))))) - - (('pipeline ('command command ('io-redirect "<<" ('here-document here-document)))) - (transform `(pipeline (lambda _ (display ,here-document)) (command ,(transform command))))) - - (('pipeline o ...) - (let ((commands (map transform o))) - `(pipeline ,@(cons (trace commands) commands)))) - - (('command o ...) `(command ,@(map transform o))) - (('literal o) (transform o)) - (('name o) o) - (('number o) o) - - ;;(('assignment a b) `(assignment ,(transform a) ',(transform b))) - ;; FIXME: to quote or not? - (('assignment a) `(substitution (variable ,(transform a)))) - (('assignment a b) `(assignment ,(transform a) ,(transform b))) - - ;; (('assignment a (and b ('literal _ ...))) `(assignment ,(transform a) ,(transform b))) - ;; (('assignment a b) - ;; `(assignment ,(transform a) ,(map transform b))) - - (('for-clause name sequence (and body ('pipeline _ ...))) - `(for ,(transform name) (lambda _ ,(transform sequence)) (lambda _ ,(transform body)))) - (('for-clause name expr body) - `(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,@(map transform body)))) - (('sequence o) - `(sequence (string-split ,(transform o) #\space))) - (('sequence o ...) - `(sequence (quote ,(map transform o)))) - - (('and l r) `(and-terms ,(transform l) ,(transform r))) - (('or l r) `(or-terms ,(transform l) ,(transform r))) - - (('substitution o) `(substitution ,(transform o))) - (('if-clause expr then) `(if-clause ,(transform expr) ,(transform then))) - (('if-clause expr then else) `(if-clause ,(transform expr) ,(transform then) ,(transform else))) - (('elif-part expr then) `(if-clause ,(transform expr) ,(transform then))) - (('elif-part expr then else) `(if-clause ,(transform expr) ,(transform then) ,(transform else))) - (('then-part o ...) `(begin ,@(map transform o))) - (('else-part o ...) `(begin ,@(map transform o))) - (('word 'singlequotes) "") - (('word o) (transform o)) - (('word o ...) `(string-append ,@(map transform o))) - - (('function name body) - `(function ,name (lambda ( . args) ,(transform body)))) - - (('brace-group o) `(brace-group ,(transform o))) - (('file-name o) `(file-name ,(transform o))) - - ('doublequotes "") - - (_ ast))) - - -(define (remove-line-comments s) - (string-join (map - (lambda (s) - (let ((n (string-index s #\#))) - (if (and n (zero? n)) (string-pad-right s (string-length s) #\space 0 n) - s))) - (string-split s #\newline)) "\n")) - -(define (parse-string string) - (let* ((pt ((compose parse- remove-line-comments) string)) - (foo (when (> %debug-level 1) (display "tree:\n") (pretty-print pt))) - (flat (flatten pt)) - (foo (when (> %debug-level 0) (display "flat:\n") (pretty-print flat))) - (ast (transform flat)) - (foo (when (> %debug-level 0) (display "ast:\n") (pretty-print ast)))) - (cond ((error? ast) - (stderr "error:") (pretty-print ast (current-error-port)) #f) - ((eq? ast 'script) - #t) - (else ast)))) - -(define (parse port) - (parse-string (read-string port))) - diff --git a/peg.scm b/peg.scm new file mode 100644 index 0000000..9b953e9 --- /dev/null +++ b/peg.scm @@ -0,0 +1,41 @@ +;;;; peg.scm --- Parsing Expression Grammar (PEG) parser generator +;;;; +;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (peg) + #:use-module (peg codegen) + #:use-module (peg string-peg) + ;; Note: the most important effect of using string-peg is not whatever + ;; functions it exports, but the fact that it adds a new handler to + ;; peg-sexp-compile. + #:use-module (peg simplify-tree) + #:use-module (peg using-parsers) + #:use-module (peg cache) + #:re-export (define-peg-pattern + define-peg-string-patterns + match-pattern + search-for-pattern + compile-peg-pattern + keyword-flatten + context-flatten + peg:start + peg:end + peg:string + peg:tree + peg:substring + peg-record?)) diff --git a/peg/cache.scm b/peg/cache.scm new file mode 100644 index 0000000..e66291d --- /dev/null +++ b/peg/cache.scm @@ -0,0 +1,45 @@ +;;;; cache.scm --- cache the results of parsing +;;;; +;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (peg cache) + #:export (cg-cached-parser)) + +;; The results of parsing using a nonterminal are cached. Think of it like a +;; hash with no conflict resolution. Process for deciding on the cache size +;; wasn't very scientific; just ran the benchmarks and stopped a little after +;; the point of diminishing returns on my box. +(define *cache-size* 512) + +(define (make-cache) + (make-vector *cache-size* #f)) + +;; given a syntax object which is a parser function, returns syntax +;; which, if evaluated, will become a parser function that uses a cache. +(define (cg-cached-parser parser) + #`(let ((cache (make-cache))) + (lambda (str strlen at) + (let* ((vref (vector-ref cache (modulo at *cache-size*)))) + ;; Check to see whether the value is cached. + (if (and vref (eq? (car vref) str) (= (cadr vref) at)) + (caddr vref);; If it is return it. + (let ((fres ;; Else calculate it and cache it. + (#,parser str strlen at))) + (vector-set! cache (modulo at *cache-size*) + (list str at fres)) + fres)))))) diff --git a/peg/codegen.scm b/peg/codegen.scm new file mode 100644 index 0000000..150f5a7 --- /dev/null +++ b/peg/codegen.scm @@ -0,0 +1,390 @@ +;;;; codegen.scm --- code generation for composable parsers +;;;; +;;;; Copyright (C) 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (peg codegen) + #:export (compile-peg-pattern wrap-parser-for-users add-peg-compiler!) + #:use-module (ice-9 pretty-print) + #:use-module (system base pmatch)) + +(define-syntax single? + (syntax-rules () + "Return #t if X is a list of one element." + ((_ x) + (pmatch x + ((_) #t) + (else #f))))) + +(define-syntax single-filter + (syntax-rules () + "If EXP is a list of one element, return the element. Otherwise +return EXP." + ((_ exp) + (pmatch exp + ((,elt) elt) + (,elts elts))))) + +(define-syntax push-not-null! + (syntax-rules () + "If OBJ is non-null, push it onto LST, otherwise do nothing." + ((_ lst obj) + (if (not (null? obj)) + (push! lst obj))))) + +(define-syntax push! + (syntax-rules () + "Push an object onto a list." + ((_ lst obj) + (set! lst (cons obj lst))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; CODE GENERATORS +;; These functions generate scheme code for parsing PEGs. +;; Conventions: +;; accum: (all name body none) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Code we generate will have a certain return structure depending on how we're +;; accumulating (the ACCUM variable). +(define (cg-generic-ret accum name body-uneval at) + ;; name, body-uneval and at are syntax + #`(let ((body #,body-uneval)) + #,(cond + ((and (eq? accum 'all) name) + #`(list #,at + (cond + ((not (list? body)) (list '#,name body)) + ((null? body) '#,name) + ((symbol? (car body)) (list '#,name body)) + (else (cons '#,name body))))) + ((eq? accum 'name) + #`(list #,at '#,name)) + ((eq? accum 'body) + #`(list #,at + (cond + ((single? body) (car body)) + (else body)))) + ((eq? accum 'none) + #`(list #,at '())) + (else + (begin + (pretty-print `(cg-generic-ret-error ,accum ,name ,body-uneval ,at)) + (pretty-print "Defaulting to accum of none.\n") + #`(list #,at '())))))) + +;; The short name makes the formatting below much easier to read. +(define cggr cg-generic-ret) + +;; Generates code that matches a particular string. +;; E.g.: (cg-string syntax "abc" 'body) +(define (cg-string pat accum) + (let ((plen (string-length pat))) + #`(lambda (str len pos) + (let ((end (+ pos #,plen))) + (and (<= end len) + (string= str #,pat pos end) + #,(case accum + ((all) #`(list end (list 'cg-string #,pat))) + ((name) #`(list end 'cg-string)) + ((body) #`(list end #,pat)) + ((none) #`(list end '())) + (else (error "bad accum" accum)))))))) + +;; Generates code for matching any character. +;; E.g.: (cg-peg-any syntax 'body) +(define (cg-peg-any accum) + #`(lambda (str len pos) + (and (< pos len) + #,(case accum + ((all) #`(list (1+ pos) + (list 'cg-peg-any (substring str pos (1+ pos))))) + ((name) #`(list (1+ pos) 'cg-peg-any)) + ((body) #`(list (1+ pos) (substring str pos (1+ pos)))) + ((none) #`(list (1+ pos) '())) + (else (error "bad accum" accum)))))) + +;; Generates code for matching a range of characters between start and end. +;; E.g.: (cg-range syntax #\a #\z 'body) +(define (cg-range pat accum) + (syntax-case pat () + ((start end) + (if (not (and (char? (syntax->datum #'start)) + (char? (syntax->datum #'end)))) + (error "range PEG should have characters after it; instead got" + #'start #'end)) + #`(lambda (str len pos) + (and (< pos len) + (let ((c (string-ref str pos))) + (and (char>=? c start) + (char<=? c end) + #,(case accum + ((all) #`(list (1+ pos) (list 'cg-range (string c)))) + ((name) #`(list (1+ pos) 'cg-range)) + ((body) #`(list (1+ pos) (string c))) + ((none) #`(list (1+ pos) '())) + (else (error "bad accum" accum)))))))))) + +;; Generate code to match a pattern and do nothing with the result +(define (cg-ignore pat accum) + (syntax-case pat () + ((inner) + (compile-peg-pattern #'inner 'none)))) + +(define (cg-capture pat accum) + (syntax-case pat () + ((inner) + (compile-peg-pattern #'inner 'body)))) + +;; Filters the accum argument to compile-peg-pattern for buildings like string +;; literals (since we don't want to tag them with their name if we're doing an +;; "all" accum). +(define (builtin-accum-filter accum) + (cond + ((eq? accum 'all) 'body) + ((eq? accum 'name) 'name) + ((eq? accum 'body) 'body) + ((eq? accum 'none) 'none))) +(define baf builtin-accum-filter) + +;; Top-level function builder for AND. Reduces to a call to CG-AND-INT. +(define (cg-and clauses accum) + #`(lambda (str len pos) + (let ((body '())) + #,(cg-and-int clauses (baf accum) #'str #'len #'pos #'body)))) + +;; Internal function builder for AND (calls itself). +(define (cg-and-int clauses accum str strlen at body) + (syntax-case clauses () + (() + (cggr accum 'cg-and #`(reverse #,body) at)) + ((first rest ...) + #`(let ((res (#,(compile-peg-pattern #'first accum) #,str #,strlen #,at))) + (and res + ;; update AT and BODY then recurse + (let ((newat (car res)) + (newbody (cadr res))) + (set! #,at newat) + (push-not-null! #,body (single-filter newbody)) + #,(cg-and-int #'(rest ...) accum str strlen at body))))))) + +;; Top-level function builder for OR. Reduces to a call to CG-OR-INT. +(define (cg-or clauses accum) + #`(lambda (str len pos) + #,(cg-or-int clauses (baf accum) #'str #'len #'pos))) + +;; Internal function builder for OR (calls itself). +(define (cg-or-int clauses accum str strlen at) + (syntax-case clauses () + (() + #f) + ((first rest ...) + #`(or (#,(compile-peg-pattern #'first accum) #,str #,strlen #,at) + #,(cg-or-int #'(rest ...) accum str strlen at))))) + +(define (cg-* args accum) + (syntax-case args () + ((pat) + #`(lambda (str strlen at) + (let ((body '())) + (let lp ((end at) (count 0)) + (let* ((match (#,(compile-peg-pattern #'pat (baf accum)) + str strlen end)) + (new-end (if match (car match) end)) + (count (if (> new-end end) (1+ count) count))) + (if (> new-end end) + (push-not-null! body (single-filter (cadr match)))) + (if (and (> new-end end) + #,#t) + (lp new-end count) + (let ((success #,#t)) + #,#`(and success + #,(cggr (baf accum) 'cg-body + #'(reverse body) #'new-end))))))))))) + +(define (cg-+ args accum) + (syntax-case args () + ((pat) + #`(lambda (str strlen at) + (let ((body '())) + (let lp ((end at) (count 0)) + (let* ((match (#,(compile-peg-pattern #'pat (baf accum)) + str strlen end)) + (new-end (if match (car match) end)) + (count (if (> new-end end) (1+ count) count))) + (if (> new-end end) + (push-not-null! body (single-filter (cadr match)))) + (if (and (> new-end end) + #,#t) + (lp new-end count) + (let ((success #,#'(>= count 1))) + #,#`(and success + #,(cggr (baf accum) 'cg-body + #'(reverse body) #'new-end))))))))))) + +(define (cg-? args accum) + (syntax-case args () + ((pat) + #`(lambda (str strlen at) + (let ((body '())) + (let lp ((end at) (count 0)) + (let* ((match (#,(compile-peg-pattern #'pat (baf accum)) + str strlen end)) + (new-end (if match (car match) end)) + (count (if (> new-end end) (1+ count) count))) + (if (> new-end end) + (push-not-null! body (single-filter (cadr match)))) + (if (and (> new-end end) + #,#'(< count 1)) + (lp new-end count) + (let ((success #,#t)) + #,#`(and success + #,(cggr (baf accum) 'cg-body + #'(reverse body) #'new-end))))))))))) + +(define (cg-followed-by args accum) + (syntax-case args () + ((pat) + #`(lambda (str strlen at) + (let ((body '())) + (let lp ((end at) (count 0)) + (let* ((match (#,(compile-peg-pattern #'pat (baf accum)) + str strlen end)) + (new-end (if match (car match) end)) + (count (if (> new-end end) (1+ count) count))) + (if (> new-end end) + (push-not-null! body (single-filter (cadr match)))) + (if (and (> new-end end) + #,#'(< count 1)) + (lp new-end count) + (let ((success #,#'(= count 1))) + #,#`(and success + #,(cggr (baf accum) 'cg-body #''() #'at))))))))))) + +(define (cg-not-followed-by args accum) + (syntax-case args () + ((pat) + #`(lambda (str strlen at) + (let ((body '())) + (let lp ((end at) (count 0)) + (let* ((match (#,(compile-peg-pattern #'pat (baf accum)) + str strlen end)) + (new-end (if match (car match) end)) + (count (if (> new-end end) (1+ count) count))) + (if (> new-end end) + (push-not-null! body (single-filter (cadr match)))) + (if (and (> new-end end) + #,#'(< count 1)) + (lp new-end count) + (let ((success #,#'(= count 1))) + #,#`(if success + #f + #,(cggr (baf accum) 'cg-body #''() #'at))))))))))) + + +(define (cg-expect-int clauses accum str strlen at) + (syntax-case clauses () + ((pat) + #`(or (#,(compile-peg-pattern #'pat accum) #,str #,strlen #,at) + (throw 'syntax-error (list #,at (syntax->datum #'pat))))))) ;;TODO throw partial match + +(define (cg-expect clauses accum) + #`(lambda (str len pos) + #,(cg-expect-int clauses ((@@ (ice-9 peg codegen) baf) accum) #'str #'len #'pos))) + +;; Association list of functions to handle different expressions as PEGs +(define peg-compiler-alist '()) + +(define (add-peg-compiler! symbol function) + (set! peg-compiler-alist + (assq-set! peg-compiler-alist symbol function))) + +(add-peg-compiler! 'range cg-range) +(add-peg-compiler! 'ignore cg-ignore) +(add-peg-compiler! 'capture cg-capture) +(add-peg-compiler! 'and cg-and) +(add-peg-compiler! 'or cg-or) +(add-peg-compiler! '* cg-*) +(add-peg-compiler! '+ cg-+) +(add-peg-compiler! '? cg-?) +(add-peg-compiler! 'followed-by cg-followed-by) +(add-peg-compiler! 'not-followed-by cg-not-followed-by) +(add-peg-compiler! 'expect cg-expect) + +;; Takes an arbitrary expressions and accumulation variable, then parses it. +;; E.g.: (compile-peg-pattern syntax '(and "abc" (or "-" (range #\a #\z))) 'all) +(define (compile-peg-pattern pat accum) + (syntax-case pat (peg-any) + (peg-any + (cg-peg-any (baf accum))) + (sym (identifier? #'sym) ;; nonterminal + #'sym) + (str (string? (syntax->datum #'str)) ;; literal string + (cg-string (syntax->datum #'str) (baf accum))) + ((name . args) (let* ((nm (syntax->datum #'name)) + (entry (assq-ref peg-compiler-alist nm))) + (if entry + (entry #'args accum) + (error "Bad peg form" nm #'args + "Not one of" (map car peg-compiler-alist))))))) + +;; Packages the results of a parser + +(define indent 0) + +(define (trace? symbol) + (and #f (not (memq symbol '())))) + +(define (wrap-parser-for-users for-syntax parser accumsym s-syn) + #`(lambda (str strlen at) + (when (trace? '#,s-syn) + (format (current-error-port) "~a~a\n" + (make-string indent #\space) + '#,s-syn)) + (set! indent (+ indent 4)) + (let ((res (#,parser str strlen at))) + (set! indent (- indent 4)) + ;; Try to match the nonterminal. + (let ((pos (or (and res (car res)) 0))) + (when (and (trace? '#,s-syn) (< at pos)) + (format (current-error-port) "~a~a := ~s\tnext: ~s\n" + (make-string indent #\space) + '#,s-syn + (substring str at pos) + (substring str pos (min strlen (+ pos 10)))))) + (if res + ;; If we matched, do some post-processing to figure out + ;; what data to propagate upward. + (let ((at (car res)) + (body (cadr res))) + #,(cond + ((eq? accumsym 'name) + #`(list at '#,s-syn)) + ((eq? accumsym 'all) + #`(list (car res) + (cond + ((not (list? body)) + (list '#,s-syn body)) + ((null? body) '#,s-syn) + ((symbol? (car body)) + (list '#,s-syn body)) + (else (cons '#,s-syn body))))) + ((eq? accumsym 'none) #`(list (car res) '())) + (else #`(begin res)))) + ;; If we didn't match, just return false. + #f)))) diff --git a/peg/simplify-tree.scm b/peg/simplify-tree.scm new file mode 100644 index 0000000..630d93c --- /dev/null +++ b/peg/simplify-tree.scm @@ -0,0 +1,97 @@ +;;;; simplify-tree.scm --- utility functions for the PEG parser +;;;; +;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (peg simplify-tree) + #:export (keyword-flatten context-flatten string-collapse) + #:use-module (system base pmatch)) + +(define-syntax single? + (syntax-rules () + "Return #t if X is a list of one element." + ((_ x) + (pmatch x + ((_) #t) + (else #f))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; POST-PROCESSING FUNCTIONS (TO CANONICALIZE MATCH TREES) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Is everything in LST true? +(define (andlst lst) + (or (null? lst) + (and (car lst) (andlst (cdr lst))))) + +;; Is LST a list of strings? +(define (string-list? lst) + (and (list? lst) (not (null? lst)) + (andlst (map string? lst)))) + +;; Groups all strings that are next to each other in LST. Used in +;; STRING-COLLAPSE. +(define (string-group lst) + (if (not (list? lst)) + lst + (if (null? lst) + '() + (let ((next (string-group (cdr lst)))) + (if (not (string? (car lst))) + (cons (car lst) next) + (if (and (not (null? next)) + (list? (car next)) + (string? (caar next))) + (cons (cons (car lst) (car next)) (cdr next)) + (cons (list (car lst)) next))))))) + + +;; Collapses all the string in LST. +;; ("a" "b" (c d) "e" "f") -> ("ab" (c d) "ef") +(define (string-collapse lst) + (if (list? lst) + (let ((res (map (lambda (x) (if (string-list? x) + (apply string-append x) + x)) + (string-group (map string-collapse lst))))) + (if (single? res) (car res) res)) + lst)) + +;; If LST is an atom, return (list LST), else return LST. +(define (mklst lst) + (if (not (list? lst)) (list lst) lst)) + +;; Takes a list and "flattens" it, using the predicate TST to know when to stop +;; instead of terminating on atoms (see tutorial). +(define (context-flatten tst lst) + (if (or (not (list? lst)) (null? lst)) + lst + (if (tst lst) + (list lst) + (apply append + (map (lambda (x) (mklst (context-flatten tst x))) + lst))))) + +;; Takes a list and "flattens" it, using the list of keywords KEYWORD-LST to +;; know when to stop at (see tutorial). +(define (keyword-flatten keyword-lst lst) + (context-flatten + (lambda (x) + (if (or (not (list? x)) (null? x)) + #t + (member (car x) keyword-lst))) + lst)) diff --git a/peg/string-peg.scm b/peg/string-peg.scm new file mode 100644 index 0000000..0943fa8 --- /dev/null +++ b/peg/string-peg.scm @@ -0,0 +1,280 @@ +;;;; string-peg.scm --- representing PEG grammars as strings +;;;; +;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (peg string-peg) + #:export (peg-as-peg + define-peg-string-patterns + peg-grammar) + #:use-module (peg using-parsers) + #:use-module (peg codegen) + #:use-module (peg simplify-tree)) + +;; Gets the left-hand depth of a list. +(define (depth lst) + (if (or (not (list? lst)) (null? lst)) + 0 + (+ 1 (depth (car lst))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; Parse string PEGs using sexp PEGs. +;; See the variable PEG-AS-PEG for an easier-to-read syntax. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Grammar for PEGs in PEG grammar. +(define peg-as-peg +"grammar <-- (nonterminal ('<--' / '<-' / '<') sp pattern)+ +pattern <-- alternative (SLASH sp alternative)* +alternative <-- ([!&]? sp suffix)+ +suffix <-- primary ([*+?] sp)* +primary <-- secondary ([#] sp)? +secondary <-- '(' sp pattern ')' sp / '.' sp / literal / charclass / nonterminal !'<' +literal <-- ['] (!['] .)* ['] sp +charclass <-- LB (!']' (CCrange / CCsingle))* RB sp +CCrange <-- . '-' . +CCsingle <-- . +nonterminal <-- [a-zA-Z0-9-]+ sp +sp < [ \t\n]* +SLASH < '/' +LB < '[' +RB < ']' +") + +(define-syntax define-sexp-parser + (lambda (x) + (syntax-case x () + ((_ sym accum pat) + (let* ((matchf (compile-peg-pattern #'pat (syntax->datum #'accum))) + (accumsym (syntax->datum #'accum)) + (syn (wrap-parser-for-users x matchf accumsym #'sym))) + #`(define sym #,syn)))))) + +(define-sexp-parser peg-grammar all + (+ (and peg-nonterminal (or "<--" "<-" "<") peg-sp peg-pattern))) +(define-sexp-parser peg-pattern all + (and peg-alternative + (* (and (ignore "/") peg-sp peg-alternative)))) +(define-sexp-parser peg-alternative all + (+ (and (? (or "!" "&")) peg-sp peg-suffix))) +(define-sexp-parser peg-suffix all + (and peg-primary (* (and (or "*" "+" "?") peg-sp)))) +(define-sexp-parser peg-primary all + (and peg-secondary (? (and "#" peg-sp)))) +(define-sexp-parser peg-secondary all + (or (and "(" peg-sp peg-pattern ")" peg-sp) + (and "." peg-sp) + peg-literal + peg-charclass + (and peg-nonterminal (not-followed-by "<")))) +(define-sexp-parser peg-literal all + (and "'" (* (and (not-followed-by "'") peg-any)) "'" peg-sp)) +(define-sexp-parser peg-charclass all + (and (ignore "[") + (* (and (not-followed-by "]") + (or charclass-range charclass-single))) + (ignore "]") + peg-sp)) +(define-sexp-parser charclass-range all (and peg-any "-" peg-any)) +(define-sexp-parser charclass-single all peg-any) +(define-sexp-parser peg-nonterminal all + (and (+ (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) "-")) peg-sp)) +(define-sexp-parser peg-sp none + (* (or " " "\t" "\n"))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; PARSE STRING PEGS +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Takes a string representing a PEG grammar and returns syntax that +;; will define all of the nonterminals in the grammar with equivalent +;; PEG s-expressions. +(define (peg-parser str for-syntax) + (let ((parsed (match-pattern peg-grammar str))) + (if (not parsed) + (begin + ;; (display "Invalid PEG grammar!\n") + #f) + (let ((lst (peg:tree parsed))) + (cond + ((or (not (list? lst)) (null? lst)) + lst) + ((eq? (car lst) 'peg-grammar) + #`(begin + #,@(map (lambda (x) (peg-nonterm->defn x for-syntax)) + (context-flatten (lambda (lst) (<= (depth lst) 2)) + (cdr lst)))))))))) + +;; Macro wrapper for PEG-PARSER. Parses PEG grammars expressed as strings and +;; defines all the appropriate nonterminals. +(define-syntax define-peg-string-patterns + (lambda (x) + (syntax-case x () + ((_ str) + (peg-parser (syntax->datum #'str) x))))) + +;; lst has format (nonterm grabber pattern), where +;; nonterm is a symbol (the name of the nonterminal), +;; grabber is a string (either "<", "<-" or "<--"), and +;; pattern is the parse of a PEG pattern expressed as as string. +(define (peg-nonterm->defn lst for-syntax) + (let* ((nonterm (car lst)) + (grabber (cadr lst)) + (pattern (caddr lst)) + (nonterm-name (datum->syntax for-syntax + (string->symbol (cadr nonterm))))) + #`(define-peg-pattern #,nonterm-name + #,(cond + ((string=? grabber "<--") (datum->syntax for-syntax 'all)) + ((string=? grabber "<-") (datum->syntax for-syntax 'body)) + (else (datum->syntax for-syntax 'none))) + #,(compressor (peg-pattern->defn pattern for-syntax) for-syntax)))) + +;; lst has format ('peg-pattern ...). +;; After the context-flatten, (cdr lst) has format +;; (('peg-alternative ...) ...), where the outer list is a collection +;; of elements from a '/' alternative. +(define (peg-pattern->defn lst for-syntax) + #`(or #,@(map (lambda (x) (peg-alternative->defn x for-syntax)) + (context-flatten (lambda (x) (eq? (car x) 'peg-alternative)) + (cdr lst))))) + +;; lst has format ('peg-alternative ...). +;; After the context-flatten, (cdr lst) has the format +;; (item ...), where each item has format either ("!" ...), ("&" ...), +;; or ('peg-suffix ...). +(define (peg-alternative->defn lst for-syntax) + #`(and #,@(map (lambda (x) (peg-body->defn x for-syntax)) + (context-flatten (lambda (x) (or (string? (car x)) + (eq? (car x) 'peg-suffix))) + (cdr lst))))) + +;; lst has the format either +;; ("!" ('peg-suffix ...)), ("&" ('peg-suffix ...)), or +;; ('peg-suffix ...). +(define (peg-body->defn lst for-syntax) + (cond + ((equal? (car lst) "&") + #`(followed-by #,(peg-suffix->defn (cadr lst) for-syntax))) + ((equal? (car lst) "!") + #`(not-followed-by #,(peg-suffix->defn (cadr lst) for-syntax))) + ((eq? (car lst) 'peg-suffix) + (peg-suffix->defn lst for-syntax)) + (else `(peg-parse-body-fail ,lst)))) + +;; lst has format ('peg-suffix (? (/ "*" "?" "+"))) +(define (peg-suffix->defn lst for-syntax) + (let ((inner-defn (peg-primary->defn (cadr lst) for-syntax))) + (cond + ((null? (cddr lst)) + inner-defn) + ((equal? (caddr lst) "*") + #`(* #,inner-defn)) + ((equal? (caddr lst) "?") + #`(? #,inner-defn)) + ((equal? (caddr lst) "+") + #`(+ #,inner-defn))))) + +;; Parse a primary. +(define (peg-primary->defn lst for-syntax) + (let ((inner-defn (peg-secondary->defn (cadr lst) for-syntax))) + (if (and (pair? (cddr lst)) (equal? (caddr lst) "#")) #`(expect #,inner-defn) + inner-defn))) + +(define (peg-secondary->defn lst for-syntax) + (let ((el (cadr lst))) + (cond + ((list? el) + (cond + ((eq? (car el) 'peg-literal) + (peg-literal->defn el for-syntax)) + ((eq? (car el) 'peg-charclass) + (peg-charclass->defn el for-syntax)) + ((eq? (car el) 'peg-nonterminal) + (datum->syntax for-syntax (string->symbol (cadr el)))))) + ((string? el) + (cond + ((equal? el "(") + (peg-pattern->defn (caddr lst) for-syntax)) + ((equal? el ".") + (datum->syntax for-syntax 'peg-any)) + (else (datum->syntax for-syntax + `(peg-parse-any unknown-string ,lst))))) + (else (datum->syntax for-syntax + `(peg-parse-any unknown-el ,lst)))))) + +;; Trims characters off the front and end of STR. +;; (trim-1chars "'ab'") -> "ab" +(define (trim-1chars str) (substring str 1 (- (string-length str) 1))) + +;; Parses a literal. +(define (peg-literal->defn lst for-syntax) + (datum->syntax for-syntax (trim-1chars (cadr lst)))) + +;; Parses a charclass. +(define (peg-charclass->defn lst for-syntax) + #`(or + #,@(map + (lambda (cc) + (cond + ((eq? (car cc) 'charclass-range) + #`(range #,(datum->syntax + for-syntax + (string-ref (cadr cc) 0)) + #,(datum->syntax + for-syntax + (string-ref (cadr cc) 2)))) + ((eq? (car cc) 'charclass-single) + (datum->syntax for-syntax (cadr cc))))) + (context-flatten + (lambda (x) (or (eq? (car x) 'charclass-range) + (eq? (car x) 'charclass-single))) + (cdr lst))))) + +;; Compresses a list to save the optimizer work. +;; e.g. (or (and a)) -> a +(define (compressor-core lst) + (if (or (not (list? lst)) (null? lst)) + lst + (cond + ((and (or (eq? (car lst) 'or) (eq? (car lst) 'and)) + (null? (cddr lst))) + (compressor-core (cadr lst))) + ((and (eq? (car lst) 'body) + (eq? (cadr lst) 'lit) + (eq? (cadddr lst) 1)) + (compressor-core (caddr lst))) + (else (map compressor-core lst))))) + +(define (compressor syn for-syntax) + (datum->syntax for-syntax + (compressor-core (syntax->datum syn)))) + +;; Builds a lambda-expressions for the pattern STR using accum. +(define (peg-string-compile args accum) + (syntax-case args () + ((str-stx) (string? (syntax->datum #'str-stx)) + (let ((string (syntax->datum #'str-stx))) + (compile-peg-pattern + (compressor + (peg-pattern->defn + (peg:tree (match-pattern peg-pattern string)) #'str-stx) + #'str-stx) + (if (eq? accum 'all) 'body accum)))) + (else (error "Bad embedded PEG string" args)))) + +(add-peg-compiler! 'peg peg-string-compile) diff --git a/peg/using-parsers.scm b/peg/using-parsers.scm new file mode 100644 index 0000000..9a141fd --- /dev/null +++ b/peg/using-parsers.scm @@ -0,0 +1,116 @@ +;;;; using-parsers.scm --- utilities to make using parsers easier +;;;; +;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (peg using-parsers) + #:use-module (peg simplify-tree) + #:use-module (peg codegen) + #:use-module (peg cache) + #:export (match-pattern define-peg-pattern search-for-pattern + prec make-prec peg:start peg:end peg:string + peg:tree peg:substring peg-record?)) + +;;; +;;; Helper Macros +;;; + +(define-syntax until + (syntax-rules () + "Evaluate TEST. If it is true, return its value. Otherwise, +execute the STMTs and try again." + ((_ test stmt stmt* ...) + (let lp () + (or test + (begin stmt stmt* ... (lp))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; FOR DEFINING AND USING NONTERMINALS +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Parses STRING using NONTERM +(define (match-pattern nonterm string) + ;; We copy the string before using it because it might have been modified + ;; in-place since the last time it was parsed, which would invalidate the + ;; cache. Guile uses copy-on-write for strings, so this is fast. + (let ((res (nonterm (string-copy string) (string-length string) 0))) + (if (not res) + #f + (make-prec 0 (car res) string (string-collapse (cadr res)))))) + +;; Defines a new nonterminal symbol accumulating with ACCUM. +(define-syntax define-peg-pattern + (lambda (x) + (syntax-case x () + ((_ sym accum pat) + (let ((matchf (compile-peg-pattern #'pat (syntax->datum #'accum))) + (accumsym (syntax->datum #'accum))) + ;; CODE is the code to parse the string if the result isn't cached. + (let ((syn (wrap-parser-for-users x matchf accumsym #'sym))) + #`(define sym #,(cg-cached-parser syn)))))))) + +(define (peg-like->peg pat) + (syntax-case pat () + (str (string? (syntax->datum #'str)) #'(peg str)) + (else pat))) + +;; Searches through STRING for something that parses to PEG-MATCHER. Think +;; regexp search. +(define-syntax search-for-pattern + (lambda (x) + (syntax-case x () + ((_ pattern string-uncopied) + (let ((pmsym (syntax->datum #'pattern))) + (let ((matcher (compile-peg-pattern (peg-like->peg #'pattern) 'body))) + ;; We copy the string before using it because it might have been + ;; modified in-place since the last time it was parsed, which would + ;; invalidate the cache. Guile uses copy-on-write for strings, so + ;; this is fast. + #`(let ((string (string-copy string-uncopied)) + (strlen (string-length string-uncopied)) + (at 0)) + (let ((ret (until (or (>= at strlen) + (#,matcher string strlen at)) + (set! at (+ at 1))))) + (if (eq? ret #t) ;; (>= at strlen) succeeded + #f + (let ((end (car ret)) + (match (cadr ret))) + (make-prec + at end string + (string-collapse match)))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; PMATCH STRUCTURE MUNGING +;; Pretty self-explanatory. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define prec + (make-record-type "peg" '(start end string tree))) +(define make-prec + (record-constructor prec '(start end string tree))) +(define (peg:start pm) + (if pm ((record-accessor prec 'start) pm) #f)) +(define (peg:end pm) + (if pm ((record-accessor prec 'end) pm) #f)) +(define (peg:string pm) + (if pm ((record-accessor prec 'string) pm) #f)) +(define (peg:tree pm) + (if pm ((record-accessor prec 'tree) pm) #f)) +(define (peg:substring pm) + (if pm (substring (peg:string pm) (peg:start pm) (peg:end pm)) #f)) +(define peg-record? (record-predicate prec)) From 7483b27f5544c04419d19017936d6a685c4f98b6 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 11 Nov 2018 21:45:37 +0100 Subject: [PATCH 225/312] Move peg into gash/, compile. --- build-aux/build-guile.sh | 15 +++++++++++---- configure | 4 ++-- gash/grammar.scm | 7 +++++-- peg.scm => gash/peg.scm | 12 ++++++------ {peg => gash/peg}/cache.scm | 2 +- {peg => gash/peg}/codegen.scm | 2 +- {peg => gash/peg}/simplify-tree.scm | 2 +- {peg => gash/peg}/string-peg.scm | 8 ++++---- {peg => gash/peg}/using-parsers.scm | 8 ++++---- 9 files changed, 35 insertions(+), 25 deletions(-) rename peg.scm => gash/peg.scm (87%) rename {peg => gash/peg}/cache.scm (98%) rename {peg => gash/peg}/codegen.scm (99%) rename {peg => gash/peg}/simplify-tree.scm (98%) rename {peg => gash/peg}/string-peg.scm (98%) rename {peg => gash/peg}/using-parsers.scm (96%) diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 10529a1..ff32da8 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -24,7 +24,7 @@ srcdir=${srcdir-.} export GUILE export GUILE_AUTO_COMPILE GUILE=${GUILE-$(command -v guile)} -GUILE_TOOLS=${GUILE_TOOLS-$(command -v guile-tools)} +GUILD=${GUILD-$(command -v guild || command -v guile-tools)} GUILE_AUTO_COMPILE=0 set -e @@ -36,12 +36,12 @@ ${srcdest}gash/builtins.scm ${srcdest}gash/compress.scm ${srcdest}gash/config.scm ${srcdest}gash/environment.scm -${srcdest}gash/geesh.scm ${srcdest}gash/gash.scm +${srcdest}gash/geesh.scm +${srcdest}gash/grammar.scm ${srcdest}gash/io.scm ${srcdest}gash/job.scm ${srcdest}gash/lzw.scm -${srcdest}gash/peg.scm ${srcdest}gash/pipe.scm ${srcdest}gash/readline.scm ${srcdest}gash/script.scm @@ -49,6 +49,13 @@ ${srcdest}gash/shell-utils.scm ${srcdest}gash/ustar.scm ${srcdest}gash/util.scm +${srcdest}gash/peg.scm +${srcdest}gash/peg/cache.scm +${srcdest}gash/peg/codegen.scm +${srcdest}gash/peg/simplify-tree.scm +${srcdest}gash/peg/string-peg.scm +${srcdest}gash/peg/using-parsers.scm + ${srcdest}gash/commands/basename.scm ${srcdest}gash/commands/cat.scm ${srcdest}gash/commands/chmod.scm @@ -116,6 +123,6 @@ for i in $SCM_FILES $SCRIPTS; do b=$(basename $i) go=${i%%.scm}.go if [ $i -nt $go ]; then - trace "GUILEC $b" $GUILE_TOOLS compile -L ${srcdir} $WARNINGS -o $go $i + trace "GUILEC $b" $GUILD compile -L ${srcdir} $WARNINGS -o $go $i fi done diff --git a/configure b/configure index a8f0c51..5c43d4e 100755 --- a/configure +++ b/configure @@ -13,7 +13,7 @@ fi BASH=$(command -v bash) GUILE=${GUILE-$(command -v guile)} -GUILE_TOOLS=${GUILE_TOOLS-$(command -v guile-tools)} +GUILD=${GUILD-$(command -v guild || command -v guile-tools)} guile_site_dir=$PREFIX/share/guile/site/$guile_effective_version guile_site_ccache_dir=$PREFIX/lib/guile/$guile_effective_version/site-ccache guile_effective_version=$(guile -c '(display (effective-version))') @@ -39,7 +39,7 @@ abs_top_builddir=$PWD cat > .config.make < %debug-level 0) + (pretty-print tree)) (if (eq? (string-length input) end) tree (if match diff --git a/peg.scm b/gash/peg.scm similarity index 87% rename from peg.scm rename to gash/peg.scm index 9b953e9..5d6ab04 100644 --- a/peg.scm +++ b/gash/peg.scm @@ -17,15 +17,15 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; -(define-module (peg) - #:use-module (peg codegen) - #:use-module (peg string-peg) +(define-module (gash peg) + #:use-module (gash peg codegen) + #:use-module (gash peg string-peg) ;; Note: the most important effect of using string-peg is not whatever ;; functions it exports, but the fact that it adds a new handler to ;; peg-sexp-compile. - #:use-module (peg simplify-tree) - #:use-module (peg using-parsers) - #:use-module (peg cache) + #:use-module (gash peg simplify-tree) + #:use-module (gash peg using-parsers) + #:use-module (gash peg cache) #:re-export (define-peg-pattern define-peg-string-patterns match-pattern diff --git a/peg/cache.scm b/gash/peg/cache.scm similarity index 98% rename from peg/cache.scm rename to gash/peg/cache.scm index e66291d..fd192b7 100644 --- a/peg/cache.scm +++ b/gash/peg/cache.scm @@ -17,7 +17,7 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; -(define-module (peg cache) +(define-module (gash peg cache) #:export (cg-cached-parser)) ;; The results of parsing using a nonterminal are cached. Think of it like a diff --git a/peg/codegen.scm b/gash/peg/codegen.scm similarity index 99% rename from peg/codegen.scm rename to gash/peg/codegen.scm index 150f5a7..9b91474 100644 --- a/peg/codegen.scm +++ b/gash/peg/codegen.scm @@ -17,7 +17,7 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; -(define-module (peg codegen) +(define-module (gash peg codegen) #:export (compile-peg-pattern wrap-parser-for-users add-peg-compiler!) #:use-module (ice-9 pretty-print) #:use-module (system base pmatch)) diff --git a/peg/simplify-tree.scm b/gash/peg/simplify-tree.scm similarity index 98% rename from peg/simplify-tree.scm rename to gash/peg/simplify-tree.scm index 630d93c..264e29e 100644 --- a/peg/simplify-tree.scm +++ b/gash/peg/simplify-tree.scm @@ -17,7 +17,7 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; -(define-module (peg simplify-tree) +(define-module (gash peg simplify-tree) #:export (keyword-flatten context-flatten string-collapse) #:use-module (system base pmatch)) diff --git a/peg/string-peg.scm b/gash/peg/string-peg.scm similarity index 98% rename from peg/string-peg.scm rename to gash/peg/string-peg.scm index 0943fa8..8797bec 100644 --- a/peg/string-peg.scm +++ b/gash/peg/string-peg.scm @@ -17,13 +17,13 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; -(define-module (peg string-peg) +(define-module (gash peg string-peg) #:export (peg-as-peg define-peg-string-patterns peg-grammar) - #:use-module (peg using-parsers) - #:use-module (peg codegen) - #:use-module (peg simplify-tree)) + #:use-module (gash peg using-parsers) + #:use-module (gash peg codegen) + #:use-module (gash peg simplify-tree)) ;; Gets the left-hand depth of a list. (define (depth lst) diff --git a/peg/using-parsers.scm b/gash/peg/using-parsers.scm similarity index 96% rename from peg/using-parsers.scm rename to gash/peg/using-parsers.scm index 9a141fd..fb8d736 100644 --- a/peg/using-parsers.scm +++ b/gash/peg/using-parsers.scm @@ -17,10 +17,10 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; -(define-module (peg using-parsers) - #:use-module (peg simplify-tree) - #:use-module (peg codegen) - #:use-module (peg cache) +(define-module (gash peg using-parsers) + #:use-module (gash peg simplify-tree) + #:use-module (gash peg codegen) + #:use-module (gash peg cache) #:export (match-pattern define-peg-pattern search-for-pattern prec make-prec peg:start peg:end peg:string peg:tree peg:substring peg-record?)) From b9b6da52b6571ecda688001dc6165ad2f1c5c6ef Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 12 Nov 2018 07:20:26 +0100 Subject: [PATCH 226/312] grammar: literal: add \. mag dat? --- gash/grammar.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index 2e28e02..2420ac6 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -169,7 +169,7 @@ ltest < '[' rtest < ']' - literal <- !reserved (!']' ![ \t\v\f\n`'\")};|&\\] .)+ + literal <- '\\'? !reserved (!']' ![ \t\v\f\n`'\")};|&\\] .)+ identifier <- [_a-zA-Z][_a-zA-Z0-9]* From b28798b0340da57cef23fd0adf2740a956b3e99f Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 12 Nov 2018 07:23:07 +0100 Subject: [PATCH 227/312] grammar: space: allow newline twice. --- gash/grammar.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index 2420ac6..3a78c14 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -96,7 +96,7 @@ (define-peg-string-patterns "script <-- ws* compound ws < sp / eol - sp < '\\\n'? (comment / [ \t\v]) + sp < '\\\n'* (comment / [ \t\v]) comment < [#] (!eol .)* eol < [\n\r\f] From 0ee86aa981238a1fff542ced60e5588bd82aa26a Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 12 Nov 2018 09:18:45 +0100 Subject: [PATCH 228/312] grammar: move variable-and, or, regex to variable toplevel. --- gash/grammar.scm | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index 3a78c14..852db7b 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -162,7 +162,8 @@ nonreserved <- !reserved word - word <-- test / substitution / assignment / number / variable / + word <-- test / substitution / assignment / number / + variable-subst / variable / delim / literal test <-- ltest sp+ (word sp+)+ rtest# @@ -185,11 +186,12 @@ assign < '=' variable <-- dollar ('*' / '@' / [0-9] / name / - lbrace name (variable-or / variable-and / variable-word / variable-literal / &rbrace) rbrace) - variable-or <-- min variable-word - variable-and <-- plus variable-word - variable-word <- (variable-regex / substitution / variable / variable-literal)+ - variable-regex <-- ('%%' / '%' / '##' / '#' / '^^' / '^' /',,' / ',' / '*' / '@' / '?')+ variable-word + lbrace name (variable-literal / &rbrace) rbrace) + variable-subst <- dollar lbrace (variable-or / variable-and / variable-regex / variable-literal / &rbrace) rbrace + variable-or <-- name min variable-word + variable-and <-- name plus variable-word + variable-word <- (variable-regex / substitution / variable-subst / variable / variable-literal)+ + variable-regex <-- name ('%%' / '%' / '##' / '#' / '^^' / '^' /',,' / ',' / '*' / '@' / '?')+ variable-word variable-literal <- (!rbrace .)+ min < '-' plus < '+' From f6a9bb4109a3d84235090a74ccdd922da52eb276 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 12 Nov 2018 07:37:44 +0100 Subject: [PATCH 229/312] grammar: strip all keywords. --- gash/grammar.scm | 33 ++++++++++++++++++++++++--------- 1 file changed, 24 insertions(+), 9 deletions(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index 852db7b..05f6cb2 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -139,23 +139,23 @@ subshell <-- lpar compound rpar# brace-group <-- lbrace ws* compound rbrace# - case-clause <-- 'case' sp* word sp* 'in'# ws* case-item+ ws* 'esac'# + case-clause <-- case-keyword sp* word sp* in-keyword# ws* case-item+ ws* esac-keyword# case-item <-- pattern sp* colon? ws* compound? case-sep? colon < ':' case-sep < ';;' ws* pattern <-- (word (!rpar '|'# / !'|' &rpar))+ rpar# - for-clause <-- 'for' sp+ identifier ws+ ('in' sp+ expression)? sep# do-group + for-clause <-- for-keyword sp+ identifier ws+ (in-keyword sp+ expression)? sep# do-group expression <-- command - do-group <-- 'do' ws+ compound 'done'# + do-group <-- do-keyword ws+ compound 'done'# - if-clause <-- 'if' sp+ compound 'then'# ws+ compound else-part? 'fi'# - else-part <-- 'else' ws+ compound / - 'elif' ws+ compound 'then'# ws+ compound else-part? + if-clause <-- if-keyword sp+ compound then-keyword# ws+ compound else-part? fi-keyword# + else-part <-- else-keyword ws+ compound / + elif-keyword ws+ compound then-keyword# ws+ compound else-part? - while-clause <-- 'while' compound do-group + while-clause <-- while-keyword compound do-group - until-clause <-- 'until' compound do-group + until-clause <-- until-keyword compound do-group reserved < ('case' / 'esac' / 'in' / 'if' / 'fi' / 'then' / 'else' / 'elif' / 'for' / 'done' / 'do' / 'until' / 'while') &ws @@ -203,7 +203,22 @@ sq < ['] dq < [\"] singlequotes <- sq (!['] .)* sq# - doublequotes <- dq (substitution / variable / (![\"] .))* dq#") + doublequotes <- dq (substitution / variable / (![\"] .))* dq# + + case-keyword < 'case' + do-keyword < 'do' + done-keyword < 'done' + elif-keyword < 'elif' + else-keyword < 'else' + esac-keyword < 'esac' + fi-keyword < 'fi' + for-keyword < 'for' + if-keyword < 'if' + in-keyword < 'in' + then-keyword < 'then' + until-keyword < 'until' + while-keyword < 'while' +") (catch 'syntax-error (lambda () From b68f8c322392509268878c4de1ce6836062d8992 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 12 Nov 2018 07:14:05 +0100 Subject: [PATCH 230/312] connect backend: WIP --- gash/bournish-commands.scm | 8 ++++---- gash/script.scm | 15 ++++++++++++++- 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 4a0d089..de42daa 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -31,11 +31,11 @@ #:use-module (gash config) #:use-module (gash shell-utils) - #:use-module (gash commands basename) + #:use-module ((gash commands basename) #:prefix gash:) #:use-module (gash commands cat) #:use-module (gash commands compress) #:use-module (gash commands cp) - #:use-module (gash commands dirname) + #:use-module ((gash commands dirname) #:prefix gash:) #:use-module (gash commands find) #:use-module (gash commands grep) #:use-module (gash commands ls) @@ -78,11 +78,11 @@ ((quit) (car args)) (else 1))))))) -(define basename-command (wrap-command basename "basename")) +(define basename-command (wrap-command "basename" gash:basename)) (define cat-command (wrap-command cat "cat")) (define compress-command (wrap-command "compress" compress)) (define cp-command (wrap-command "cp" cp)) -(define dirname-command (wrap-command "dirname" dirname)) +(define dirname-command (wrap-command "dirname" gash:dirname)) (define find-command (wrap-command "find" find)) (define grep-command (wrap-command "grep" grep)) (define ls-command (wrap-command "ls" ls)) diff --git a/gash/script.scm b/gash/script.scm index 84649d3..1530d69 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -168,7 +168,9 @@ (match o ((h t ...) (append (flatten h) (append-map flatten t))) (_ (list o)))) - (string-join (flatten o) "")) + (match o + (((? string?) ...) (string-join (flatten o) "")) + (_ o))) (define-syntax-rule (substitution commands) (string-trim-right (with-output-to-string (lambda _ commands)))) @@ -368,3 +370,14 @@ replace (substring value (match:end match))) value)))) + +(define (compound . o) + (match (warn 'compound o) + ((h ... t) t) + (_ o))) + +(define (delim o) + o) + +(define (name o) + o) From 6449c3424af418511b05a7dab09f7823394ff72d Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 12 Nov 2018 10:52:39 +0100 Subject: [PATCH 231/312] check-parse: new target. 5 parse failures. --- check.sh | 14 +++++++++----- makefile | 3 +++ 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/check.sh b/check.sh index bd6022a..26d1749 100755 --- a/check.sh +++ b/check.sh @@ -55,9 +55,9 @@ tests=" 11-for 11-for-split-sequence -20-semi.sh -20-or.sh -20-and.sh +20-semi +20-or +20-and 20-pipe-exit-0 20-pipe-exit-1 20-pipe-sed @@ -71,7 +71,7 @@ tests=" 40-eval-echo-variable 40-assignment-eval-echo -41-dot.sh +41-dot 50-iohere @@ -117,7 +117,11 @@ pass=0 fail=0 total=0 for t in $tests; do - sh test.sh "test/$t" &> test/"$t".log + if [ "$PARSE" ]; then + bin/gash -p "test/$t.sh" + else + sh test.sh "test/$t" &> test/"$t".log + fi r=$? total=$((total+1)) if [ $r = 0 ]; then diff --git a/makefile b/makefile index b51e361..6b866c2 100644 --- a/makefile +++ b/makefile @@ -35,6 +35,9 @@ endif check-gash: all SHELL=bin/gash ./check.sh +check-parse: all + SHELL='bin/gash -p' PARSE=1 ./check.sh + check-geesh: all SHELL='bin/gash --geesh' ./check.sh From 983b9b355a980aad9b260169dd03028629ea3f86 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Tue, 13 Nov 2018 07:21:56 +0100 Subject: [PATCH 232/312] pass make check-parse --- gash/grammar.scm | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index 05f6cb2..328b564 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -162,15 +162,15 @@ nonreserved <- !reserved word - word <-- test / substitution / assignment / number / - variable-subst / variable / - delim / literal + word <-- test / substitution / assignment / + (number / variable / variable-subst / delim / literal)+ test <-- ltest sp+ (word sp+)+ rtest# ltest < '[' rtest < ']' - literal <- '\\'? !reserved (!']' ![ \t\v\f\n`'\")};|&\\] .)+ + literal <- !reserved (!']' ![ \t\v\f\n`'\")};|&$] (escape / .))+ + escape <- '\\' [ \"$] identifier <- [_a-zA-Z][_a-zA-Z0-9]* @@ -187,7 +187,7 @@ variable <-- dollar ('*' / '@' / [0-9] / name / lbrace name (variable-literal / &rbrace) rbrace) - variable-subst <- dollar lbrace (variable-or / variable-and / variable-regex / variable-literal / &rbrace) rbrace + variable-subst <- dollar lbrace (variable-or / variable-and / variable-regex / &rbrace) rbrace variable-or <-- name min variable-word variable-and <-- name plus variable-word variable-word <- (variable-regex / substitution / variable-subst / variable / variable-literal)+ @@ -202,8 +202,8 @@ delim <-- singlequotes / doublequotes / substitution sq < ['] dq < [\"] - singlequotes <- sq (!['] .)* sq# - doublequotes <- dq (substitution / variable / (![\"] .))* dq# + singlequotes <- sq (!sq .)* sq# + doublequotes <- dq (substitution / variable / (!dq ('\\\"' / .)))* dq# case-keyword < 'case' do-keyword < 'do' From d667922bbdac229d06ea1f760f542e32c86d4568 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Tue, 13 Nov 2018 09:02:35 +0100 Subject: [PATCH 233/312] narrow escape --- check.sh | 1 + gash/grammar.scm | 6 ++++-- test/00-exit-2.exit | 1 + test/00-exit-2.sh | 1 + test/01-script-backslash.exit | 2 +- test/01-script-backslash.sh | 2 +- 6 files changed, 9 insertions(+), 4 deletions(-) create mode 100644 test/00-exit-2.exit create mode 100644 test/00-exit-2.sh diff --git a/check.sh b/check.sh index 26d1749..8723001 100755 --- a/check.sh +++ b/check.sh @@ -8,6 +8,7 @@ tests=" 00-exit 00-exit-0 00-exit-1 +00-exit-2 01-script-newline 01-script-semi diff --git a/gash/grammar.scm b/gash/grammar.scm index 328b564..506e10c 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -169,8 +169,10 @@ ltest < '[' rtest < ']' - literal <- !reserved (!']' ![ \t\v\f\n`'\")};|&$] (escape / .))+ - escape <- '\\' [ \"$] + literal <- !reserved (escaped / !allowed .)+ + escaped <- escape [ \"$] + escape < [\\] + allowed <- ']' / [ \t\v\f\n`'\")};|&$] / '\\\n' identifier <- [_a-zA-Z][_a-zA-Z0-9]* diff --git a/test/00-exit-2.exit b/test/00-exit-2.exit new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/test/00-exit-2.exit @@ -0,0 +1 @@ +2 diff --git a/test/00-exit-2.sh b/test/00-exit-2.sh new file mode 100644 index 0000000..6b0593e --- /dev/null +++ b/test/00-exit-2.sh @@ -0,0 +1 @@ +exit 2 diff --git a/test/01-script-backslash.exit b/test/01-script-backslash.exit index 0cfbf08..573541a 100644 --- a/test/01-script-backslash.exit +++ b/test/01-script-backslash.exit @@ -1 +1 @@ -2 +0 diff --git a/test/01-script-backslash.sh b/test/01-script-backslash.sh index 71cb744..0e662fd 100644 --- a/test/01-script-backslash.sh +++ b/test/01-script-backslash.sh @@ -1,2 +1,2 @@ exit\ - 2 + 0 From 98868392c844bf55bd04c543909eb6960413bd5f Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 14 Nov 2018 08:22:00 +0100 Subject: [PATCH 234/312] cleanup commented out code --- gash/grammar.scm | 56 ------------------------------------------------ 1 file changed, 56 deletions(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index 506e10c..b8e342b 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -12,62 +12,6 @@ #:export (parse parse-string)) -;; (define-syntax define-unwrapped-sexp-parser -;; (lambda (x) -;; (syntax-case x () -;; ((_ sym accum pat) -;; (let* ((matchf (compile-peg-pattern #'pat (syntax->datum #'accum)))) -;; #`(define sym #,matchf)))))) - -;; (define-unwrapped-sexp-parser eol none (or "\f" "\n" "\r")) -;; (add-peg-compiler! 'eol eol) - -;; (define-unwrapped-sexp-parser ws none (or " " "\t" "\v")) -;; (add-peg-compiler! 'ws ws) - -;; (define-unwrapped-sexp-parser line none (and "#" (* (and (not-followed-by eol) peg-any)))) -;; (add-peg-compiler! 'line line) - -;; (define-unwrapped-sexp-parser skip none (* (or ws eol line))) -;; (add-peg-compiler! 'skip skip) - -;; (define (wrap-skip-parser-for-users for-syntax parser accumsym s-syn) -;; (display "wrap\n") -;; #`(lambda (str strlen pos) -;; (when #t -;; (format (current-error-port) "~a ~a : ~s\n" -;; (make-string (- pos (or (string-rindex str #\newline 0 pos) 0)) #\space) -;; '#,s-syn -;; (substring str pos (min (+ pos 40) strlen)))) - -;; (let* ((res (skip str strlen pos)) -;; (pos (or (and res (car res)) pos)) -;; (res (#,parser str strlen pos))) -;; ;; Try to match the nonterminal. -;; (if res -;; ;; If we matched, do some post-processing to figure out -;; ;; what data to propagate upward. -;; (let* ((at (car res)) -;; (body (cadr res))) -;; #,(cond -;; ((eq? accumsym 'name) -;; #``(,at ,'#,s-syn)) -;; ((eq? accumsym 'all) -;; #`(list at -;; (cond -;; ((not (list? body)) -;; `(,'#,s-syn ,body)) -;; ((null? body) `(,'#,s-syn)) -;; ((symbol? (car body)) -;; `(,'#,s-syn ,body)) -;; (else (cons '#,s-syn body))))) -;; ((eq? accumsym 'none) #``(,at ())) -;; (else #``(,at ,body)))) -;; ;; If we didn't match, just return false. -;; #f)))) - -;; (module-set! (resolve-module '(peg codegen)) 'wrap-parser-for-users wrap-skip-parser-for-users) - (define (parse port) (parse-string (read-string port))) From 6e88ad23d041f4acdcf302fe7a7b6e701493883a Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 14 Nov 2018 08:22:12 +0100 Subject: [PATCH 235/312] place assignment at the proper grammar level --- gash/grammar.scm | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index b8e342b..a83a117 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -69,13 +69,27 @@ compound-command <- (subshell / brace-group / for-clause / case-clause / if-clause / while-clause / until-clause) (sp* io-redirect)* - simple-command <- ((io-redirect / nonreserved) sp*)+ + simple-command <- ((io-redirect / assignment) sp*)* + ((io-redirect / nonreserved) sp*)+ / + ((io-redirect / assignment) sp*)+ + ((io-redirect / nonreserved) sp*)* + + assignment <-- name assign word? + assign < '=' + io-redirect <-- [0-9]* (io-here / io-file) io-file <-- io-op ([0-9]+ / word) io-op <- '<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|' io-here <-- io-here-op io-here-label sp* eol io-here-document io-here-op <- '<<-' / '<<' + reserved < ('case' / 'esac' / 'in' / 'if' / 'fi' / 'then' / 'else' / + 'elif' / 'for' / 'done' / 'do' / 'until' / 'while') &ws + nonreserved <- !reserved word + + word <-- test / substitution / + (number / variable / variable-subst / delim / literal)+ + function-def <-- name sp* lpar rpar# ws* function-body name <-- !reserved identifier function-body <-- brace-group (sp* io-redirect)* @@ -101,14 +115,6 @@ until-clause <-- until-keyword compound do-group - reserved < ('case' / 'esac' / 'in' / 'if' / 'fi' / 'then' / 'else' / - 'elif' / 'for' / 'done' / 'do' / 'until' / 'while') &ws - - nonreserved <- !reserved word - - word <-- test / substitution / assignment / - (number / variable / variable-subst / delim / literal)+ - test <-- ltest sp+ (word sp+)+ rtest# ltest < '[' rtest < ']' @@ -128,9 +134,6 @@ rpar < ')' bt < [`] - assignment <-- name assign word? - assign < '=' - variable <-- dollar ('*' / '@' / [0-9] / name / lbrace name (variable-literal / &rbrace) rbrace) variable-subst <- dollar lbrace (variable-or / variable-and / variable-regex / &rbrace) rbrace From da105e0e817e54d4d9126619029441e4795bdd57 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 14 Nov 2018 19:31:00 +0100 Subject: [PATCH 236/312] fix 05-assignment-empty.sh --- gash/environment.scm | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/gash/environment.scm b/gash/environment.scm index 9121b50..792dc8e 100644 --- a/gash/environment.scm +++ b/gash/environment.scm @@ -53,11 +53,13 @@ (define %functions '()) -(define (assignment name value) - (and value - (set! %global-variables - (assoc-set! %global-variables name value)) - #t)) +(define* (assignment name #:optional value) + (if value + (set! %global-variables + (assoc-set! %global-variables name value)) + (set! %global-variables + (assoc-set! %global-variables name ""))) + #t) (define* (variable name #:optional (default "")) (cond ((string->number name) From aa8aa101514b194ef39a1836d0ab4a350bea8ab9 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 14 Nov 2018 19:31:29 +0100 Subject: [PATCH 237/312] fix 05-assignment-doublequoted-doubleqoutes.sh --- gash/grammar.scm | 2 +- gash/script.scm | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index a83a117..7608ff6 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -152,7 +152,7 @@ sq < ['] dq < [\"] singlequotes <- sq (!sq .)* sq# - doublequotes <- dq (substitution / variable / (!dq ('\\\"' / .)))* dq# + doublequotes <- dq (substitution / variable / (!dq (escape '\"' / .)))* dq# case-keyword < 'case' do-keyword < 'do' diff --git a/gash/script.scm b/gash/script.scm index 1530d69..b1f3e6e 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -376,8 +376,8 @@ ((h ... t) t) (_ o))) -(define (delim o) - o) +(define (delim . o) + (string-join o "")) (define (name o) o) From 03dcfb9a9f718a483fe7d7bf5bc3eb1e7cb48515 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 14 Nov 2018 19:40:46 +0100 Subject: [PATCH 238/312] fix 08-variable-and.sh --- gash/grammar.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index 7608ff6..9a7c3ae 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -141,7 +141,7 @@ variable-and <-- name plus variable-word variable-word <- (variable-regex / substitution / variable-subst / variable / variable-literal)+ variable-regex <-- name ('%%' / '%' / '##' / '#' / '^^' / '^' /',,' / ',' / '*' / '@' / '?')+ variable-word - variable-literal <- (!rbrace .)+ + variable-literal <- (!rbrace !min !plus .)+ min < '-' plus < '+' lbrace < '{' From c20ac38ace8c10978bb7866b09aaba42b3f167a7 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 14 Nov 2018 19:46:02 +0100 Subject: [PATCH 239/312] fix 08-variable-not-and.sh --- gash/environment.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gash/environment.scm b/gash/environment.scm index 792dc8e..bbb566d 100644 --- a/gash/environment.scm +++ b/gash/environment.scm @@ -82,7 +82,7 @@ (define (variable-and name default) (let ((value (variable name #f))) - (and value default))) + (if value default ""))) (define (set-shell-opt! name set?) (let* ((shell-opts (variable "SHELLOPTS")) From 1fe85e2b8f21ec82dc59cf9a00a095f9bdeb7417 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 14 Nov 2018 19:50:43 +0100 Subject: [PATCH 240/312] fix 10-if-word-variable.sh (HACK) --- gash/script.scm | 3 +++ 1 file changed, 3 insertions(+) diff --git a/gash/script.scm b/gash/script.scm index b1f3e6e..19465b3 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -381,3 +381,6 @@ (define (name o) o) + +(define (test . o) ;; TODO replace with implementation in scheme + (apply command (cons "test" o))) From bb79378e66f18ba4a026df195c1bfa0d8bee58f6 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 14 Nov 2018 19:59:18 +0100 Subject: [PATCH 241/312] fix 10-if-else.sh and 10-if-elif.sh --- gash/script.scm | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/gash/script.scm b/gash/script.scm index 19465b3..7affb21 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -197,6 +197,17 @@ #'(let ((it (ignore-error expr))) (if (zero? it) then else))))))) +(define-syntax else-part + (lambda (x) + (syntax-case x () + ((_ else) + (with-syntax ((it (datum->syntax x 'it))) + #'else)) + ((_ expr then else) + (with-syntax ((it (datum->syntax x 'it))) + #'(let ((it (ignore-error expr))) + (if (zero? it) then else))))))) + (define-syntax and-terms (lambda (x) (syntax-case x () From efd22ab9594cdf9ff5f4d87d474078c4da2ef06b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 14 Nov 2018 21:09:21 +0100 Subject: [PATCH 242/312] fix 11-for.sh. --- gash/grammar.scm | 2 +- gash/script.scm | 22 ++++++++++++++++++---- 2 files changed, 19 insertions(+), 5 deletions(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index 9a7c3ae..9bb650d 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -105,7 +105,7 @@ for-clause <-- for-keyword sp+ identifier ws+ (in-keyword sp+ expression)? sep# do-group expression <-- command - do-group <-- do-keyword ws+ compound 'done'# + do-group <-- do-keyword ws+ compound done-keyword# if-clause <-- if-keyword sp+ compound then-keyword# ws+ compound else-part? fi-keyword# else-part <-- else-keyword ws+ compound / diff --git a/gash/script.scm b/gash/script.scm index 7affb21..22cb99c 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -47,7 +47,9 @@ command doublequotes file-name - for + for-clause + do-group + expression glob if-clause ignore-error @@ -148,11 +150,11 @@ (define (script . o) o) -(define (for name sequence body) +(define (for-clause name sequence body) (for-each (lambda (value) (assignment name value) (body)) - (sequence))) + sequence)) (define (split o) ((compose string-tokenize string-trim-right) o)) @@ -208,6 +210,18 @@ #'(let ((it (ignore-error expr))) (if (zero? it) then else))))))) +(define-syntax expression + (lambda (x) + (syntax-case x () + ((_ (command word ...)) + #'(list word ...))))) + +(define-syntax do-group + (lambda (x) + (syntax-case x () + ((_ term ...) + #'(lambda _ term ...))))) + (define-syntax and-terms (lambda (x) (syntax-case x () @@ -383,7 +397,7 @@ value)))) (define (compound . o) - (match (warn 'compound o) + (match o ((h ... t) t) (_ o))) From 049c4a20dcc21d64963b64ca5d0a3512d44a21b1 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 14 Nov 2018 22:40:52 +0100 Subject: [PATCH 243/312] cat: Oops, two fixes. --- gash/bournish-commands.scm | 2 +- gash/commands/cat.scm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index de42daa..e3ac04c 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -79,7 +79,7 @@ (else 1))))))) (define basename-command (wrap-command "basename" gash:basename)) -(define cat-command (wrap-command cat "cat")) +(define cat-command (wrap-command "cat" cat)) (define compress-command (wrap-command "compress" compress)) (define cp-command (wrap-command "cp" cp)) (define dirname-command (wrap-command "dirname" gash:dirname)) diff --git a/gash/commands/cat.scm b/gash/commands/cat.scm index dd1ad18..bd9a505 100644 --- a/gash/commands/cat.scm +++ b/gash/commands/cat.scm @@ -36,6 +36,6 @@ (call-with-input-file file (lambda (port) (dump-port port (current-output-port)))))) - 0 args)) + 0 (if (null? args) '("-") args))) (define main cat) From b6340bd612b02083d961728eed93745920706a37 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 14 Nov 2018 22:41:24 +0100 Subject: [PATCH 244/312] io-redirect: some progress, some new tests. --- check.sh | 3 +++ gash/grammar.scm | 2 +- gash/script.scm | 18 ++++++++++++++++-- test/50-redirect-in.sh | 1 + test/50-redirect-space.sh | 3 +++ test/50-redirect-space.stdout | 1 + test/50-redirect.sh | 3 +++ test/50-redirect.stdout | 1 + 8 files changed, 29 insertions(+), 3 deletions(-) create mode 100644 test/50-redirect-in.sh create mode 100644 test/50-redirect-space.sh create mode 100644 test/50-redirect-space.stdout create mode 100644 test/50-redirect.sh create mode 100644 test/50-redirect.stdout diff --git a/check.sh b/check.sh index 8723001..e8d3a69 100755 --- a/check.sh +++ b/check.sh @@ -75,6 +75,9 @@ tests=" 41-dot 50-iohere +50-redirect +50-redirect-space +50-redirect-in 60-function 60-subst diff --git a/gash/grammar.scm b/gash/grammar.scm index 9bb650d..dcf8064 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -78,7 +78,7 @@ assign < '=' io-redirect <-- [0-9]* (io-here / io-file) - io-file <-- io-op ([0-9]+ / word) + io-file <-- io-op ([0-9]+ / sp* word) io-op <- '<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|' io-here <-- io-here-op io-here-label sp* eol io-here-document io-here-op <- '<<-' / '<<' diff --git a/gash/script.scm b/gash/script.scm index 22cb99c..1320803 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -74,7 +74,7 @@ (('pipeline command) (pke 'background: `(pipeline+ #f ,command))) (_ term))) -(define (command . args) +(define (exec-command . args) (define (exec command) (cond ((procedure? command) command) ((assoc-ref %functions (car command)) @@ -177,6 +177,20 @@ (define-syntax-rule (substitution commands) (string-trim-right (with-output-to-string (lambda _ commands)))) +(define-syntax command + (lambda (x) + (syntax-case x () + ((_ word ... (io-redirect (io-file "<" file-name))) + #'(with-input-from-file file-name (command word ...))) + ((_ word ... (io-redirect (io-file ">" file-name))) + #'(with-output-to-file file-name (command word ...))) + ((_ word ... (io-redirect "1" (io-file ">" file-name))) + #'(with-output-to-file file-name (command word ...))) + ((_ word ... (io-redirect "2" (io-file ">" file-name))) + #'(with-error-to-file file-name (command word ...))) + ((_ word ...) + #'(exec-command word ...))))) + (define-syntax-rule (ignore-error o) (let ((errexit (shell-opt? "errexit"))) (when errexit @@ -408,4 +422,4 @@ o) (define (test . o) ;; TODO replace with implementation in scheme - (apply command (cons "test" o))) + (command (cons "test" o))) diff --git a/test/50-redirect-in.sh b/test/50-redirect-in.sh new file mode 100644 index 0000000..9e18426 --- /dev/null +++ b/test/50-redirect-in.sh @@ -0,0 +1 @@ +\cat < test/data/foo diff --git a/test/50-redirect-space.sh b/test/50-redirect-space.sh new file mode 100644 index 0000000..fe40da0 --- /dev/null +++ b/test/50-redirect-space.sh @@ -0,0 +1,3 @@ +echo foo > bar +cat bar +rm bar diff --git a/test/50-redirect-space.stdout b/test/50-redirect-space.stdout new file mode 100644 index 0000000..257cc56 --- /dev/null +++ b/test/50-redirect-space.stdout @@ -0,0 +1 @@ +foo diff --git a/test/50-redirect.sh b/test/50-redirect.sh new file mode 100644 index 0000000..da5cff4 --- /dev/null +++ b/test/50-redirect.sh @@ -0,0 +1,3 @@ +echo foo 1>./bar +cat bar +rm bar diff --git a/test/50-redirect.stdout b/test/50-redirect.stdout new file mode 100644 index 0000000..257cc56 --- /dev/null +++ b/test/50-redirect.stdout @@ -0,0 +1 @@ +foo From 303746a4bc268f7dd55310c132b5390f84392944 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 14 Nov 2018 22:49:06 +0100 Subject: [PATCH 245/312] io-here. --- check.sh | 1 + gash/script.scm | 2 ++ test/50-iohere-builtin.sh | 3 +++ 3 files changed, 6 insertions(+) create mode 100644 test/50-iohere-builtin.sh diff --git a/check.sh b/check.sh index e8d3a69..8b735ac 100755 --- a/check.sh +++ b/check.sh @@ -75,6 +75,7 @@ tests=" 41-dot 50-iohere +50-iohere-builtin 50-redirect 50-redirect-space 50-redirect-in diff --git a/gash/script.scm b/gash/script.scm index 1320803..5a39f7b 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -188,6 +188,8 @@ #'(with-output-to-file file-name (command word ...))) ((_ word ... (io-redirect "2" (io-file ">" file-name))) #'(with-error-to-file file-name (command word ...))) + ((_ word ... (io-redirect (io-here "<<" (io-here-document string)))) + #'(pipeline (cut display string) (command word ...))) ((_ word ...) #'(exec-command word ...))))) diff --git a/test/50-iohere-builtin.sh b/test/50-iohere-builtin.sh new file mode 100644 index 0000000..c6c1126 --- /dev/null +++ b/test/50-iohere-builtin.sh @@ -0,0 +1,3 @@ +\cat < Date: Wed, 14 Nov 2018 22:57:52 +0100 Subject: [PATCH 246/312] sed: Support substitution of \t, \n. --- gash/commands/sed.scm | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/gash/commands/sed.scm b/gash/commands/sed.scm index d8f8f94..cb10bc1 100644 --- a/gash/commands/sed.scm +++ b/gash/commands/sed.scm @@ -44,6 +44,15 @@ (char-numeric? (cadr lst))) (let ((i (- (char->integer (cadr lst)) (char->integer #\0)))) (append (string->list (match:substring m i)) (loop (cddr lst))))) + ((and (eq? (car lst) #\\) + (eq? (cadr lst) #\n)) + (append '(#\newline) (cddr lst))) + ((and (eq? (car lst) #\\) + (eq? (cadr lst) #\t)) + (append '(#\tab) (cddr lst))) + ((and (eq? (car lst) #\\) + (eq? (cadr lst) #\r)) + (append '(#\return) (cddr lst))) ((and (eq? (car lst) #\\) (eq? (cadr lst) #\\)) (append '(#\\ #\\) (cddr lst))) From d36ee815dfbe5e4bbef30975a4b03a2e625b5c12 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Thu, 15 Nov 2018 19:57:10 +0100 Subject: [PATCH 247/312] variable-regex: fix 70-*.sh --- gash/grammar.scm | 18 +++++++++++------- gash/script.scm | 24 ++++++++++++++++++++++++ 2 files changed, 35 insertions(+), 7 deletions(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index dcf8064..6a464c5 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -87,8 +87,8 @@ 'elif' / 'for' / 'done' / 'do' / 'until' / 'while') &ws nonreserved <- !reserved word - word <-- test / substitution / - (number / variable / variable-subst / delim / literal)+ + word <-- test / substitution / + (number / variable-subst / variable / delim / literal)+ function-def <-- name sp* lpar rpar# ws* function-body name <-- !reserved identifier @@ -136,12 +136,16 @@ variable <-- dollar ('*' / '@' / [0-9] / name / lbrace name (variable-literal / &rbrace) rbrace) - variable-subst <- dollar lbrace (variable-or / variable-and / variable-regex / &rbrace) rbrace + variable-subst <- dollar lbrace (variable-or / variable-and / variable-regex) rbrace variable-or <-- name min variable-word variable-and <-- name plus variable-word - variable-word <- (variable-regex / substitution / variable-subst / variable / variable-literal)+ - variable-regex <-- name ('%%' / '%' / '##' / '#' / '^^' / '^' /',,' / ',' / '*' / '@' / '?')+ variable-word - variable-literal <- (!rbrace !min !plus .)+ + variable-word <- variable-regex / substitution / variable-subst / variable / variable-literal !slash / variable-string + variable-regex <-- name &slash regex-sep variable-literal '/' variable-string &rbrace / + name regex-sep variable-string + slash < '/' + variable-string <- (!rbrace .)+ + variable-literal <- (!rbrace !min !plus !slash .)+ + regex-sep <-- ('/' / '%%' / '%' / '##' / '#' / '^^' / '^' /',,' / ',' / '*' / '@' / '?') min < '-' plus < '+' lbrace < '{' @@ -152,7 +156,7 @@ sq < ['] dq < [\"] singlequotes <- sq (!sq .)* sq# - doublequotes <- dq (substitution / variable / (!dq (escape '\"' / .)))* dq# + doublequotes <- dq (substitution / variable-subst / variable / (!dq (escape '\"' / .)))* dq# case-keyword < 'case' do-keyword < 'do' diff --git a/gash/script.scm b/gash/script.scm index 5a39f7b..da7b4e8 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -177,6 +177,12 @@ (define-syntax-rule (substitution commands) (string-trim-right (with-output-to-string (lambda _ commands)))) +;; (define (substitution . command) +;; (if (string? (car command)) (warn (parse-string (string-join command))) +;; (pipeline->string (list command)) +;; (warn 'substitution: command '=> )) +;; ) + (define-syntax command (lambda (x) (syntax-case x () @@ -351,6 +357,21 @@ (or (regexp-exec regexp (substring string start)) (loop (1- start))))))) +(define (variable-regex name sep pattern) + (match sep + ("##" (variable-hash-hash name pattern)) + ("#" (variable-hash name pattern)) + ("%%" (variable-percent-percent name pattern)) + ("%" (variable-percent name pattern)) + ("/" (variable-replace name pattern)))) + +(define (variable-replace name pattern) + (let* ((value (variable name)) + (at (string-index pattern #\/)) + (regex (if at (substring pattern 0 at) pattern)) + (subst (if at (substring pattern (1+ at)) ""))) + (regexp-substitute/global #f regex value 'pre subst 'post))) + (define (variable-hash name pattern) (let ((value (variable name)) (glob? (glob? pattern))) @@ -423,5 +444,8 @@ (define (name o) o) +(define (regex-sep o) + o) + (define (test . o) ;; TODO replace with implementation in scheme (command (cons "test" o))) From 2dc0a56ff99fab3ec9365eef6eeb24fe21e205d5 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Thu, 15 Nov 2018 20:54:59 +0100 Subject: [PATCH 248/312] guix: replace recipe with guile-only (bootstrappable) build. --- gash/shell-utils.scm | 2 +- guix.scm | 120 +++++++++++++++++++++++++++++++++---------- 2 files changed, 95 insertions(+), 27 deletions(-) diff --git a/gash/shell-utils.scm b/gash/shell-utils.scm index 6883579..288a7c6 100644 --- a/gash/shell-utils.scm +++ b/gash/shell-utils.scm @@ -513,7 +513,7 @@ end of a line; by itself it won't match the terminating newline of a line." ((-) (logand mode (logxor n -1))) (else (error (format #f - "program: operation not supported: ~s\n" + "~a: operation not supported: ~s\n" program o)))))) (define (apply-chmodifiers file modifiers) diff --git a/guix.scm b/guix.scm index 15b0c88..8943233 100644 --- a/guix.scm +++ b/guix.scm @@ -53,14 +53,14 @@ (gnu packages texinfo) ((guix build utils) #:select (with-directory-excursion)) (guix build-system gnu) - (guix build-system trivial) + (guix build-system guile) (guix gexp) (guix download) (guix git-download) - (guix licenses) + ((guix licenses) #:prefix license:) (guix packages)) -(define %source-dir (dirname (current-filename))) +(define %source-dir (getcwd)) (define git-file? (let* ((pipe (with-directory-excursion %source-dir @@ -79,42 +79,110 @@ (any (cut string-suffix? <> file) files)) (_ #f))))) -(define-public gash - (let ((commit "7b9871478b573e14fa94a84f3585c2cbed6f02a3") +(define-public guile-gash + (let ((version "0.1") + (commit "b555d291a973565bcb9c13a6121d00f2f01c92f7") (revision "0") - (version "0.1")) + (builtins '( + "basename" + "cat" + "chmod" + "compress" + "cp" + "dirname" + "find" + "grep" + "ls" + "mkdir" + "reboot" + "rm" + "rmdir" + "sed" + "tar" + "touch" + "wc " + "which" + )) + (shells '("bash" "gash" "sh"))) (package - (name "gash") + (name "guile-gash") (version (string-append version "-" revision "." (string-take commit 7))) (source (origin - (method git-fetch) - (uri (git-reference - (url "https://gitlab.com/janneke/gash") - (commit commit))) - (file-name (string-append name "-" version)) + (method url-fetch) + (uri (string-append "https://gitlab.com/janneke/gash" + "/-/archive/" commit + "/gash-" commit ".tar.gz")) (sha256 - (base32 "11708vl2f04xpgs57mac4z7illx6wf4ybb32mh9ajfwimlkvwl4f")))) - (build-system gnu-build-system) - (propagated-inputs - `(("guile-readline" ,guile-readline))) - (inputs - `(("guile" ,guile-2.2))) + (base32 + "07g0m6c3s5562py0ypbjzzg82a5vgmnsyg6vd5476ad5q0z23f9k")))) + (build-system guile-build-system) + (arguments + `(#:phases + (modify-phases %standard-phases + (add-after 'unpack 'remove-geesh + (lambda _ + (delete-file "guix.scm") ; should not and cannot be compiled + (delete-file "gash/geesh.scm") ; no Geesh yet + #t)) + (add-after 'unpack 'configure + (lambda* (#:key inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (guile (assoc-ref inputs "guile")) + (bin/guile (string-append guile "/bin/guile")) + (effective (target-guile-effective-version)) + (guile-site-dir + (string-append out "/share/guile/site/" effective)) + (guile-site-ccache-dir + (string-append out + "/lib/guile/" effective "/site-ccache"))) + (define (make-script source name) + (let ((script (string-append "bin/" name))) + (copy-file source script) + (substitute* script + (("@GUILE@") bin/guile) + (("@guile_site_dir@") guile-site-dir) + (("@guile_site_ccache_dir@") guile-site-ccache-dir) + (("@builtin@") name)) + (chmod script #o755))) + (copy-file "gash/config.scm.in" "gash/config.scm") + (substitute* "gash/config.scm" + (("@guile_site_ccache_dir@") guile-site-ccache-dir) + (("@VERSION@") ,version) + (("@COMPRESS@") (string-append out "/bin/compress")) + (("@BZIP2@") (which "bzip2")) + (("@GZIP@") (which "gzip")) + (("@XZ@") (which "xz"))) + (for-each + (lambda (s) (make-script "bin/gash.in" s)) ',shells) + (for-each + (lambda (s) (make-script "bin/builtin.in" s)) ',builtins)) + #t)) + (add-after 'install 'install-scripts + (lambda* (#:key inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (bin (string-append out "/bin"))) + (for-each + (lambda (name) + (install-file (string-append "bin/" name) bin)) + ',(append builtins shells))) + #t))))) (native-inputs - `(("texinfo" ,texinfo))) - (synopsis "A POSIX compliant sh replacement for Guile.") + `(("guile" ,guile-2.2) + ("guile-readline" ,guile-readline))) + (home-page "https://gitlab.com/rutgervanbeusekom/gash") + (synopsis "Guile As SHell") (description - "Gash [Guile As Shell] aims to produce at least a POSIX compliant sh replacement -or even implement GNU bash. On top of that it also intends to make -scheme available for interactive and scripting application.") - (home-page "https://gitlab.com/rutger.van.beusekom/gash") - (license gpl3+)))) + "Gash--Guile As SHell-- aims to produce at least a POSIX compliant sh +replacement or even implement GNU bash. On top of that it also intends to +make Scheme available for interactive and scripting application.") + (license license:gpl3+)))) (define-public gash.git (let ((version "0.1") (revision "0") (commit (read-string (open-pipe "git show HEAD | head -1 | cut -d ' ' -f 2" OPEN_READ)))) (package - (inherit gash) + (inherit guile-gash) (name "gash.git") (version (string-append version "-" revision "." (string-take commit 7))) (source (local-file %source-dir #:recursive? #t #:select? git-file?))))) From 96d55d098523dea5ab08fbf25829310199db3ec0 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 16 Nov 2018 18:50:44 +0100 Subject: [PATCH 249/312] guix: install bournish in libexec/gash. --- guix.scm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/guix.scm b/guix.scm index 8943233..9123d94 100644 --- a/guix.scm +++ b/guix.scm @@ -81,7 +81,7 @@ (define-public guile-gash (let ((version "0.1") - (commit "b555d291a973565bcb9c13a6121d00f2f01c92f7") + (commit "cb8671f3125b8acbfdc28a9ab169a2e8c38b2a49") (revision "0") (builtins '( "basename" @@ -114,7 +114,7 @@ "/gash-" commit ".tar.gz")) (sha256 (base32 - "07g0m6c3s5562py0ypbjzzg82a5vgmnsyg6vd5476ad5q0z23f9k")))) + "1i51qz4xl6ija77jrjdq5r3y4p0jl3kzii1d7i3kyd8rydxycgj5")))) (build-system guile-build-system) (arguments `(#:phases @@ -160,10 +160,12 @@ (add-after 'install 'install-scripts (lambda* (#:key inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) - (bin (string-append out "/bin"))) + (bin (string-append out "/bin")) + (libexec/gash (string-append out "/libexec/gash"))) + (install-file "bin/gash" bin) (for-each (lambda (name) - (install-file (string-append "bin/" name) bin)) + (install-file (string-append "bin/" name) libexec/gash)) ',(append builtins shells))) #t))))) (native-inputs From b89ca17134ee9c44bc0b44cc88ec361946c7cec4 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 17 Nov 2018 08:33:13 +0100 Subject: [PATCH 250/312] transform: rewrite io-redirection. --- gash/grammar.scm | 22 +++++++++++++++++++++- gash/script.scm | 24 +----------------------- 2 files changed, 22 insertions(+), 24 deletions(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index 6a464c5..757b608 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -179,9 +179,14 @@ (end (peg:end match)) (tree (peg:tree match))) (when (> %debug-level 0) + (format #t "parse tree:\n") (pretty-print tree)) (if (eq? (string-length input) end) - tree + (let ((script (transform tree))) + (when (> %debug-level 0) + (format #t "script:\n") + (pretty-print script)) + script) (if match (begin (format (current-error-port) "parse error: at offset: ~a\n" end) @@ -220,3 +225,18 @@ indent (format-peg (cadar args))) (exit 1)))))) + +(define (transform o) + (match o + (('command word ... ('io-redirect ('io-here "<<" ('io-here-document string)))) + `(pipeline (cut display ,string) (command ,@word))) + (('command word ... ('io-redirect filedes ... ('io-file ">" file-name))) + (cond ((or (null? filedes) (equal? filedes '("1"))) + `(with-output-to-file ,file-name (command ,@word))) + ((equal? filedes '("2")) + `(with-error-to-file ,file-name (command ,@word))) + (else (error (format #f "TODO: output to filedes=~a\n" filedes))))) + (('command word ... ('io-redirect ('io-file "<" file-name))) + `(with-input-from-file ,file-name (command ,@word))) + ((h t ...) (map transform o)) + (_ o))) diff --git a/gash/script.scm b/gash/script.scm index da7b4e8..01de558 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -74,7 +74,7 @@ (('pipeline command) (pke 'background: `(pipeline+ #f ,command))) (_ term))) -(define (exec-command . args) +(define (command . args) (define (exec command) (cond ((procedure? command) command) ((assoc-ref %functions (car command)) @@ -177,28 +177,6 @@ (define-syntax-rule (substitution commands) (string-trim-right (with-output-to-string (lambda _ commands)))) -;; (define (substitution . command) -;; (if (string? (car command)) (warn (parse-string (string-join command))) -;; (pipeline->string (list command)) -;; (warn 'substitution: command '=> )) -;; ) - -(define-syntax command - (lambda (x) - (syntax-case x () - ((_ word ... (io-redirect (io-file "<" file-name))) - #'(with-input-from-file file-name (command word ...))) - ((_ word ... (io-redirect (io-file ">" file-name))) - #'(with-output-to-file file-name (command word ...))) - ((_ word ... (io-redirect "1" (io-file ">" file-name))) - #'(with-output-to-file file-name (command word ...))) - ((_ word ... (io-redirect "2" (io-file ">" file-name))) - #'(with-error-to-file file-name (command word ...))) - ((_ word ... (io-redirect (io-here "<<" (io-here-document string)))) - #'(pipeline (cut display string) (command word ...))) - ((_ word ...) - #'(exec-command word ...))))) - (define-syntax-rule (ignore-error o) (let ((errexit (shell-opt? "errexit"))) (when errexit From df73d5421ff56f8957712de3d9cb03268b6e5086 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 17 Nov 2018 08:43:46 +0100 Subject: [PATCH 251/312] transform: translate script to begin or command. --- gash/grammar.scm | 5 +++++ gash/script.scm | 4 ---- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index 757b608..941d940 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -228,6 +228,10 @@ (define (transform o) (match o + + (('script command) (transform command)) + (('script command ...) `(begin ,@(map transform command))) + (('command word ... ('io-redirect ('io-here "<<" ('io-here-document string)))) `(pipeline (cut display ,string) (command ,@word))) (('command word ... ('io-redirect filedes ... ('io-file ">" file-name))) @@ -238,5 +242,6 @@ (else (error (format #f "TODO: output to filedes=~a\n" filedes))))) (('command word ... ('io-redirect ('io-file "<" file-name))) `(with-input-from-file ,file-name (command ,@word))) + ((h t ...) (map transform o)) (_ o))) diff --git a/gash/script.scm b/gash/script.scm index 01de558..bcdcc9a 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -57,7 +57,6 @@ or-terms pipeline run - script script-status sequence singlequotes @@ -147,9 +146,6 @@ (define (script-status) ((compose string->number variable) "?")) -(define (script . o) - o) - (define (for-clause name sequence body) (for-each (lambda (value) (assignment name value) From 9d1ed9ef57fa0052a316e1fc77869eeaff678b44 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 17 Nov 2018 09:57:46 +0100 Subject: [PATCH 252/312] transform: if-clause->if. --- gash/grammar.scm | 34 ++++++++++++++++++++++++++++++++-- gash/script.scm | 40 ++++++++++++++++++---------------------- 2 files changed, 50 insertions(+), 24 deletions(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index 941d940..eff4e53 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -108,8 +108,8 @@ do-group <-- do-keyword ws+ compound done-keyword# if-clause <-- if-keyword sp+ compound then-keyword# ws+ compound else-part? fi-keyword# - else-part <-- else-keyword ws+ compound / - elif-keyword ws+ compound then-keyword# ws+ compound else-part? + else-part <-- else-keyword ws+ compound / elif + elif <-- elif-keyword ws+ compound then-keyword# ws+ compound else-part? while-clause <-- while-keyword compound do-group @@ -232,6 +232,19 @@ (('script command) (transform command)) (('script command ...) `(begin ,@(map transform command))) + ;; FIXME: cannot remove pipeline even if it's a single command + ;; `pipeline' is what executes commands and evaluates them + ;; (set -e) + ;; (('pipeline pipeline) (transform pipeline)) + ;; or it results in ((if ...)); which won't work either + ;; (('pipeline pipeline) (let ((x (transform pipeline))) + ;; (match x + ;; (('command command ...) (list x)) + ;; (_ x)))) + + (('compound compound) (transform compound)) + (('compound compound ...) `(begin ,@(map transform compound))) + (('command word ... ('io-redirect ('io-here "<<" ('io-here-document string)))) `(pipeline (cut display ,string) (command ,@word))) (('command word ... ('io-redirect filedes ... ('io-file ">" file-name))) @@ -243,5 +256,22 @@ (('command word ... ('io-redirect ('io-file "<" file-name))) `(with-input-from-file ,file-name (command ,@word))) + (('command ('if-clause if-clause ...)) + (transform `(if-clause ,@if-clause))) + (('if-clause expr then) + `(if (true? ,(transform expr)) ,(transform then) 0)) + (('if-clause expr then ('else-part else)) + `(if (true? ,(transform expr)) ,(transform then) ,(transform else))) + (('if-clause expr then ..1) + `(if (true? ,(transform expr)) (begin ,@(map transform then)) 0)) + (('if-clause expr then ..1 ('else-part else)) + `(if (true? ,(transform expr)) (begin ,@(map transform then)) ,(transform else))) + (('if-clause expr then ('else-part else ..1)) + `(if (true? ,(transform expr)) ,(transform then) ,@(map transform else))) + (('if-clause expr then ..1 ('else-part else ..1)) + `(if (true? ,(transform expr)) (begin ,@(map transform then)) (begin ,@(map transform else)))) + + (('elif elif ...) (transform `(if-clause ,@elif))) + ((h t ...) (map transform o)) (_ o))) diff --git a/gash/script.scm b/gash/script.scm index bcdcc9a..ebb2802 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -51,7 +51,6 @@ do-group expression glob - if-clause ignore-error literal or-terms @@ -140,8 +139,12 @@ (let ((glob (append-map glob (apply append args)))) glob)) -(define (run ast) - (map (cut local-eval <> (the-environment)) ast)) +(define (run script) + ;; fixme: work towards simple eval -- must remove begin for now + (match script + (('begin script ...) + (last (map (cut local-eval <> (the-environment)) script))) + (_ (local-eval script (the-environment))))) (define (script-status) ((compose string->number variable) "?")) @@ -183,28 +186,19 @@ (set-shell-opt! " errexit" #t)) r))) -(define-syntax if-clause +(define-syntax true? (lambda (x) (syntax-case x () - ((_ expr then) + ((_ pipeline) (with-syntax ((it (datum->syntax x 'it))) - #'(let ((it (ignore-error expr))) - (if (zero? it) then)))) - ((_ expr then else) - (with-syntax ((it (datum->syntax x 'it))) - #'(let ((it (ignore-error expr))) - (if (zero? it) then else))))))) + #'(let ((it (ignore-error pipeline))) + (status->bool it))))))) -(define-syntax else-part - (lambda (x) - (syntax-case x () - ((_ else) - (with-syntax ((it (datum->syntax x 'it))) - #'else)) - ((_ expr then else) - (with-syntax ((it (datum->syntax x 'it))) - #'(let ((it (ignore-error expr))) - (if (zero? it) then else))))))) +(define (status->bool o) + (match o + (#t #t) + ((? number?) (zero? o)) + (_ #f))) (define-syntax expression (lambda (x) @@ -258,8 +252,10 @@ (assignment "?" (number->string status)) (when (and (not (zero? status)) (shell-opt? "errexit")) + (when (> %debug-level 0) + (format (current-error-port) "set -e: exiting\n")) (exit status)) - status)) + (status->bool status))) (let ((commands (filter (lambda (x) (not (eq? x *unspecified*))) commands))) (when (> %debug-level 1) (format (current-error-port) "pijp: commands=~s\n" commands)) From 74454c2156ae3b7d8b44609dc5bbce2a77f1614b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 17 Nov 2018 19:23:51 +0100 Subject: [PATCH 253/312] transform: handle ./source. --- gash/grammar.scm | 2 ++ gash/script.scm | 6 ++++++ 2 files changed, 8 insertions(+) diff --git a/gash/grammar.scm b/gash/grammar.scm index eff4e53..5f7d4e3 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -245,6 +245,8 @@ (('compound compound) (transform compound)) (('compound compound ...) `(begin ,@(map transform compound))) + (('command (word (or "." "source")) file-name) + `(source ,(transform file-name))) (('command word ... ('io-redirect ('io-here "<<" ('io-here-document string)))) `(pipeline (cut display ,string) (command ,@word))) (('command word ... ('io-redirect filedes ... ('io-file ">" file-name))) diff --git a/gash/script.scm b/gash/script.scm index ebb2802..3afb959 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -59,6 +59,7 @@ script-status sequence singlequotes + source splice split substitution @@ -72,6 +73,11 @@ (('pipeline command) (pke 'background: `(pipeline+ #f ,command))) (_ term))) +(define (source file-name) + (let* ((string (with-input-from-file file-name read-string)) + (ast (parse-string string))) + (run ast))) + (define (command . args) (define (exec command) (cond ((procedure? command) command) From 992479b0a365f178217606afa65463675d6ee252 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 17 Nov 2018 20:08:01 +0100 Subject: [PATCH 254/312] 11-for-subshell: new failing parse test. --- check.sh | 1 + test/11-for-done-subshell.sh | 1 + 2 files changed, 2 insertions(+) create mode 100644 test/11-for-done-subshell.sh diff --git a/check.sh b/check.sh index 8b735ac..74ec3ee 100755 --- a/check.sh +++ b/check.sh @@ -55,6 +55,7 @@ tests=" 11-for 11-for-split-sequence +11-for-subshell 20-semi 20-or diff --git a/test/11-for-done-subshell.sh b/test/11-for-done-subshell.sh new file mode 100644 index 0000000..08ffa46 --- /dev/null +++ b/test/11-for-done-subshell.sh @@ -0,0 +1 @@ +(for i in 0; do echo $i; done) From bdbc29e448350bdf2e56047c5c6ac3afafb2c1a4 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 17 Nov 2018 20:08:17 +0100 Subject: [PATCH 255/312] transform: reduce simple commands...WIP --- gash/grammar.scm | 3 +++ 1 file changed, 3 insertions(+) diff --git a/gash/grammar.scm b/gash/grammar.scm index 5f7d4e3..1e06712 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -258,6 +258,9 @@ (('command word ... ('io-redirect ('io-file "<" file-name))) `(with-input-from-file ,file-name (command ,@word))) + (('command ('word (and (? string?) string)) ...) + `(command ,@string)) + (('command ('if-clause if-clause ...)) (transform `(if-clause ,@if-clause))) (('if-clause expr then) From b9013153f2ee98e0bec6fb07396e2be4494a3eaa Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 18 Nov 2018 15:36:04 +0100 Subject: [PATCH 256/312] test: 07-variable-or-variable.sh: New failing parse test. --- check.sh | 1 + test/07-variable-or-variable.sh | 2 ++ test/07-variable-or-variable.stdout | 1 + 3 files changed, 4 insertions(+) create mode 100644 test/07-variable-or-variable.sh create mode 100644 test/07-variable-or-variable.stdout diff --git a/check.sh b/check.sh index 74ec3ee..14ce24b 100755 --- a/check.sh +++ b/check.sh @@ -40,6 +40,7 @@ tests=" 07-variable-or 07-variable-not-or 07-variable-or-slash +07-variable-or-variable 08-variable-and 08-variable-not-and diff --git a/test/07-variable-or-variable.sh b/test/07-variable-or-variable.sh new file mode 100644 index 0000000..3fe8df8 --- /dev/null +++ b/test/07-variable-or-variable.sh @@ -0,0 +1,2 @@ +prefix=/usr +echo ${bindir-$prefix/bin} diff --git a/test/07-variable-or-variable.stdout b/test/07-variable-or-variable.stdout new file mode 100644 index 0000000..415f082 --- /dev/null +++ b/test/07-variable-or-variable.stdout @@ -0,0 +1 @@ +/usr/bin From 43f79811aa1bf2687153a205c54cc3c27357d50d Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 24 Nov 2018 10:55:24 +0100 Subject: [PATCH 257/312] fix 07-variable-or-variable.sh. --- gash/environment.scm | 8 ++++---- gash/grammar.scm | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/gash/environment.scm b/gash/environment.scm index bbb566d..ec179bd 100644 --- a/gash/environment.scm +++ b/gash/environment.scm @@ -77,12 +77,12 @@ #f) default))))) -(define (variable-or name default) - (variable name default)) +(define (variable-or name . default) + (variable name (apply string-append default))) -(define (variable-and name default) +(define (variable-and name . default) (let ((value (variable name #f))) - (if value default ""))) + (if value (apply string-append default) ""))) (define (set-shell-opt! name set?) (let* ((shell-opts (variable "SHELLOPTS")) diff --git a/gash/grammar.scm b/gash/grammar.scm index 1e06712..602e632 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -137,8 +137,8 @@ variable <-- dollar ('*' / '@' / [0-9] / name / lbrace name (variable-literal / &rbrace) rbrace) variable-subst <- dollar lbrace (variable-or / variable-and / variable-regex) rbrace - variable-or <-- name min variable-word - variable-and <-- name plus variable-word + variable-or <-- name min variable-word variable-word* + variable-and <-- name plus variable-word variable-word* variable-word <- variable-regex / substitution / variable-subst / variable / variable-literal !slash / variable-string variable-regex <-- name &slash regex-sep variable-literal '/' variable-string &rbrace / name regex-sep variable-string From 2df901d3379805b464bad672288ff2c08b7f01f9 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 24 Nov 2018 11:05:46 +0100 Subject: [PATCH 258/312] 50-redirect-append.sh: New failing parse test. --- check.sh | 1 + test/50-redirect-append.sh | 4 ++++ test/50-redirect-append.stdout | 2 ++ 3 files changed, 7 insertions(+) create mode 100644 test/50-redirect-append.sh create mode 100644 test/50-redirect-append.stdout diff --git a/check.sh b/check.sh index 14ce24b..2026fd0 100755 --- a/check.sh +++ b/check.sh @@ -81,6 +81,7 @@ tests=" 50-redirect 50-redirect-space 50-redirect-in +50-redirect-append 60-function 60-subst diff --git a/test/50-redirect-append.sh b/test/50-redirect-append.sh new file mode 100644 index 0000000..c6c8db9 --- /dev/null +++ b/test/50-redirect-append.sh @@ -0,0 +1,4 @@ +echo foo > bar +echo foo >> bar +cat bar +rm bar diff --git a/test/50-redirect-append.stdout b/test/50-redirect-append.stdout new file mode 100644 index 0000000..0d55bed --- /dev/null +++ b/test/50-redirect-append.stdout @@ -0,0 +1,2 @@ +foo +foo From 58d1627b083ff25ca8a12a1a2b2637b45c58c6c5 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 24 Nov 2018 11:12:44 +0100 Subject: [PATCH 259/312] fix 60-function.sh. --- gash/grammar.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index 602e632..64fb5d6 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -64,7 +64,7 @@ exclamation <- '!' pipe < sp* '|' !'|' ws* - command <-- function-def / compound-command / simple-command + command <-- function / compound-command / simple-command compound-command <- (subshell / brace-group / for-clause / case-clause / if-clause / while-clause / until-clause) (sp* io-redirect)* @@ -90,9 +90,9 @@ word <-- test / substitution / (number / variable-subst / variable / delim / literal)+ - function-def <-- name sp* lpar rpar# ws* function-body + function <-- name sp* lpar rpar# ws* function-body name <-- !reserved identifier - function-body <-- brace-group (sp* io-redirect)* + function-body <- brace-group (sp* io-redirect)* subshell <-- lpar compound rpar# brace-group <-- lbrace ws* compound rbrace# @@ -278,5 +278,8 @@ (('elif elif ...) (transform `(if-clause ,@elif))) + (('function name body) + `(function ,name (lambda ( . args) ,(transform body)))) + ((h t ...) (map transform o)) (_ o))) From f81b526bd0d4c6b26b0ec9b1ac524f1f3e139c76 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 24 Nov 2018 11:32:33 +0100 Subject: [PATCH 260/312] fix and test cd builtin. --- check.sh | 3 +++ gash/builtins.scm | 10 ++++++++-- test/100-cd-foo.exit | 1 + test/100-cd-foo.sh | 1 + test/100-cd.sh | 2 ++ test/100-cd.stdout | 1 + 6 files changed, 16 insertions(+), 2 deletions(-) create mode 100644 test/100-cd-foo.exit create mode 100644 test/100-cd-foo.sh create mode 100644 test/100-cd.sh create mode 100644 test/100-cd.stdout diff --git a/check.sh b/check.sh index 2026fd0..8ddfde4 100755 --- a/check.sh +++ b/check.sh @@ -95,6 +95,9 @@ tests=" 70-slash-string 70-slash-string-slash +100-cd +100-cd-foo + 100-sed 100-sed-once 100-sed-global diff --git a/gash/builtins.scm b/gash/builtins.scm index 1c3073a..6be4c95 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -65,8 +65,14 @@ ((dir) (let ((old (variable "OLDPWD"))) (assignment "OLDPWD" (getcwd)) - (if (string=? dir "-") (chdir old) - (chdir dir)))) + (catch #t + (lambda _ + (if (string=? dir "-") (chdir old) + (chdir dir)) + 0) + (lambda (key command fmt args exit) + (apply format (current-error-port) "cd: ~a: ~a\n" (cons dir args)) + 1)))) ((args ...) (format (current-error-port) "cd: too many arguments: ~a\n" (string-join args))))) diff --git a/test/100-cd-foo.exit b/test/100-cd-foo.exit new file mode 100644 index 0000000..d00491f --- /dev/null +++ b/test/100-cd-foo.exit @@ -0,0 +1 @@ +1 diff --git a/test/100-cd-foo.sh b/test/100-cd-foo.sh new file mode 100644 index 0000000..92a9b5c --- /dev/null +++ b/test/100-cd-foo.sh @@ -0,0 +1 @@ +cd /foo diff --git a/test/100-cd.sh b/test/100-cd.sh new file mode 100644 index 0000000..16911ea --- /dev/null +++ b/test/100-cd.sh @@ -0,0 +1,2 @@ +cd /bin +pwd diff --git a/test/100-cd.stdout b/test/100-cd.stdout new file mode 100644 index 0000000..5e56e04 --- /dev/null +++ b/test/100-cd.stdout @@ -0,0 +1 @@ +/bin From b2f5004eb6a2c77897a3fc24b5acfe5b677c0e4e Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 24 Nov 2018 12:03:32 +0100 Subject: [PATCH 261/312] 01-script-$0.sh, 01-script-$@.sh: add test and fix. --- check.sh | 8 +++++--- gash/environment.scm | 2 ++ gash/gash.scm | 8 +++++--- test.sh | 18 +++++++++--------- test/01-script-$0.sh | 2 ++ test/01-script-$@.sh | 1 + test/01-script-$@.stdout | 1 + test/for-done-subshell.stdout | 1 + 8 files changed, 26 insertions(+), 15 deletions(-) create mode 100644 test/01-script-$0.sh create mode 100644 test/01-script-$@.sh create mode 100644 test/01-script-$@.stdout create mode 100644 test/for-done-subshell.stdout diff --git a/check.sh b/check.sh index 8ddfde4..4ede1e0 100755 --- a/check.sh +++ b/check.sh @@ -4,7 +4,7 @@ fi DIFF=diff SHELL=${SHELL-bin/gash} -tests=" +tests=' 00-exit 00-exit-0 00-exit-1 @@ -15,6 +15,8 @@ tests=" 01-script-backslash 01-script-backslash-space 01-script-backslash-twice +01-script-$0 +01-script-$@ 03-echo 03-echo-doublequotes @@ -56,7 +58,7 @@ tests=" 11-for 11-for-split-sequence -11-for-subshell +11-for-done-subshell 20-semi 20-or @@ -112,7 +114,7 @@ tests=" 100-tar-Z 100-tar-Z-old 100-tar-Z-pipe -" +' broken=" " diff --git a/gash/environment.scm b/gash/environment.scm index ec179bd..c772e9b 100644 --- a/gash/environment.scm +++ b/gash/environment.scm @@ -67,6 +67,8 @@ (lambda (n) (if (< n (length (%command-line))) (list-ref (%command-line) n) ""))) + ((equal? name "@") + (string-join (cdr (%command-line)))) ((equal? name "#") (number->string (length (%command-line)))) (else diff --git a/gash/gash.scm b/gash/gash.scm index f5925e6..37a95c9 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -122,9 +122,11 @@ copyleft. (run ast)) (exit (script-status)))) ((pair? files) - (let ((asts (map file-to-ast files))) - (if parse? (map pretty-print asts) - (for-each run asts)) + (let* ((script (car files)) + (ast (file-to-ast script))) + (if parse? (pretty-print ast) + (parameterize ((%command-line files)) + (run ast))) (exit (script-status)))) (builtin-command-line (let* ((builtin (car builtin-command-line)) diff --git a/test.sh b/test.sh index 3a0f097..c1c7591 100755 --- a/test.sh +++ b/test.sh @@ -5,21 +5,21 @@ fi DIFF=${DIFF-diff} SHELL=${SHELL-bin/gash} -t=$1 -b=test/$(basename $t .sh) +t="$1" +b=test/$(basename "$t" .sh) set +e -timeout 1 $SHELL -e $b.sh > $b.1 2> $b.2 +timeout 1 $SHELL -e "$b".sh -s --long file0 file1 > "$b".1 2> "$b".2 r=$? set -e -if [ -f $b.exit ]; then - e=$(cat $b.exit) +if [ -f "$b".exit ]; then + e=$(cat "$b".exit) else e=0 fi [ $r = $e ] || exit 1 -if [ -f $b.stdout ]; then - $DIFF -u $b.stdout $b.1 +if [ -f "$b".stdout ]; then + $DIFF -u "$b".stdout $b.1 fi -if [ -f $b.stderr ]; then - $DIFF -u $b.stderr $b.2 +if [ -f "$b".stderr ]; then + $DIFF -u "$b".stderr "$b".2 fi diff --git a/test/01-script-$0.sh b/test/01-script-$0.sh new file mode 100644 index 0000000..afb2377 --- /dev/null +++ b/test/01-script-$0.sh @@ -0,0 +1,2 @@ +echo $0 + diff --git a/test/01-script-$@.sh b/test/01-script-$@.sh new file mode 100644 index 0000000..46445d8 --- /dev/null +++ b/test/01-script-$@.sh @@ -0,0 +1 @@ +echo $@ diff --git a/test/01-script-$@.stdout b/test/01-script-$@.stdout new file mode 100644 index 0000000..48c3024 --- /dev/null +++ b/test/01-script-$@.stdout @@ -0,0 +1 @@ +-s --long file0 file1 diff --git a/test/for-done-subshell.stdout b/test/for-done-subshell.stdout new file mode 100644 index 0000000..573541a --- /dev/null +++ b/test/for-done-subshell.stdout @@ -0,0 +1 @@ +0 From 9ac8140cf4b3ca0aab501f94f9d7544334934601 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 24 Nov 2018 12:55:57 +0100 Subject: [PATCH 262/312] test: 07-variable-or-doublequete.sh: New failing parse test. --- check.sh | 1 + gash/grammar.scm | 4 +++- gash/script.scm | 1 + test/07-variable-or-doublequote.sh | 4 ++++ test/07-variable-or-doublequote.stdout | 1 + 5 files changed, 10 insertions(+), 1 deletion(-) create mode 100644 test/07-variable-or-doublequote.sh create mode 100644 test/07-variable-or-doublequote.stdout diff --git a/check.sh b/check.sh index 4ede1e0..db7486d 100755 --- a/check.sh +++ b/check.sh @@ -43,6 +43,7 @@ tests=' 07-variable-not-or 07-variable-or-slash 07-variable-or-variable +07-variable-or-doublequote 08-variable-and 08-variable-not-and diff --git a/gash/grammar.scm b/gash/grammar.scm index 64fb5d6..1658eab 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -245,7 +245,7 @@ (('compound compound) (transform compound)) (('compound compound ...) `(begin ,@(map transform compound))) - (('command (word (or "." "source")) file-name) + (('command ('word (or "." "source")) file-name) `(source ,(transform file-name))) (('command word ... ('io-redirect ('io-here "<<" ('io-here-document string)))) `(pipeline (cut display ,string) (command ,@word))) @@ -281,5 +281,7 @@ (('function name body) `(function ,name (lambda ( . args) ,(transform body)))) + (('word 'delim) '(word "")) + ((h t ...) (map transform o)) (_ o))) diff --git a/gash/script.scm b/gash/script.scm index 3afb959..1a2b5bf 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -45,6 +45,7 @@ brace-group builtin command + delim doublequotes file-name for-clause diff --git a/test/07-variable-or-doublequote.sh b/test/07-variable-or-doublequote.sh new file mode 100644 index 0000000..04af4f2 --- /dev/null +++ b/test/07-variable-or-doublequote.sh @@ -0,0 +1,4 @@ +CPPFLAGS=${CPPFLAGS-" +-I ${srcdest}src +"} +echo $CPPFLAGS diff --git a/test/07-variable-or-doublequote.stdout b/test/07-variable-or-doublequote.stdout new file mode 100644 index 0000000..3bb5bf4 --- /dev/null +++ b/test/07-variable-or-doublequote.stdout @@ -0,0 +1 @@ +-I src From cb0505400695978b086d9b4375eb82f36502b6d6 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 24 Nov 2018 13:10:38 +0100 Subject: [PATCH 263/312] fix parsing of 07-variable-or-doublequete.sh. --- gash/grammar.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index 1658eab..3c620c3 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -143,8 +143,8 @@ variable-regex <-- name &slash regex-sep variable-literal '/' variable-string &rbrace / name regex-sep variable-string slash < '/' - variable-string <- (!rbrace .)+ - variable-literal <- (!rbrace !min !plus !slash .)+ + variable-string <- (!rbrace ((!dq !sq .) / delim))+ + variable-literal <- (!rbrace !min !plus !slash ((!dq !sq .) / delim))+ regex-sep <-- ('/' / '%%' / '%' / '##' / '#' / '^^' / '^' /',,' / ',' / '*' / '@' / '?') min < '-' plus < '+' From 3c7b22febf2abf7e8f1e64c6dfd64912c01b8966 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 24 Nov 2018 13:17:21 +0100 Subject: [PATCH 264/312] test: add 42-sh.sh --- check.sh | 1 + test/41-dot.stdout | 2 ++ test/42-sh.sh | 2 ++ test/42-sh.stdout | 2 ++ test/data/script.sh | 1 + 5 files changed, 8 insertions(+) create mode 100644 test/41-dot.stdout create mode 100644 test/42-sh.sh create mode 100644 test/42-sh.stdout diff --git a/check.sh b/check.sh index db7486d..ac43138 100755 --- a/check.sh +++ b/check.sh @@ -78,6 +78,7 @@ tests=' 40-assignment-eval-echo 41-dot +42-sh 50-iohere 50-iohere-builtin diff --git a/test/41-dot.stdout b/test/41-dot.stdout new file mode 100644 index 0000000..a486f1a --- /dev/null +++ b/test/41-dot.stdout @@ -0,0 +1,2 @@ +bar +bar diff --git a/test/42-sh.sh b/test/42-sh.sh new file mode 100644 index 0000000..aeb1a25 --- /dev/null +++ b/test/42-sh.sh @@ -0,0 +1,2 @@ +sh test/data/script.sh +echo $foo diff --git a/test/42-sh.stdout b/test/42-sh.stdout new file mode 100644 index 0000000..9972d7e --- /dev/null +++ b/test/42-sh.stdout @@ -0,0 +1,2 @@ +bar + diff --git a/test/data/script.sh b/test/data/script.sh index 74d0a43..4b4cd91 100644 --- a/test/data/script.sh +++ b/test/data/script.sh @@ -1 +1,2 @@ foo=bar +echo $foo From 29ae8bc5708acf6819a834ff0860dcc161ab0f83 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 24 Nov 2018 20:48:21 +0100 Subject: [PATCH 265/312] test: add substitution tests. --- check.sh | 2 ++ test/30-substitution-assignment.sh | 5 ++--- test/30-substitution-assignment.stdout | 2 +- test/30-substitution-redirect.sh | 1 + test/30-substitution-redirect.stdout | 1 + 5 files changed, 7 insertions(+), 4 deletions(-) create mode 100644 test/30-substitution-redirect.sh create mode 100644 test/30-substitution-redirect.stdout diff --git a/check.sh b/check.sh index ac43138..566c1d9 100755 --- a/check.sh +++ b/check.sh @@ -72,6 +72,8 @@ tests=' 30-substitution-backtick 30-substitution-assignment 30-for-substitution +30-substitution-assignment +30-substitution-redirect 40-eval 40-eval-echo-variable diff --git a/test/30-substitution-assignment.sh b/test/30-substitution-assignment.sh index 8792ff3..816efa7 100644 --- a/test/30-substitution-assignment.sh +++ b/test/30-substitution-assignment.sh @@ -1,3 +1,2 @@ -f=test/test.sh -b=test/$(basename $f .sh) -echo b=$b +echo=$(echo 1 2 3) +echo echo=$echo diff --git a/test/30-substitution-assignment.stdout b/test/30-substitution-assignment.stdout index 94facae..7e6732e 100644 --- a/test/30-substitution-assignment.stdout +++ b/test/30-substitution-assignment.stdout @@ -1 +1 @@ -b=test/test +echo=1 2 3 diff --git a/test/30-substitution-redirect.sh b/test/30-substitution-redirect.sh new file mode 100644 index 0000000..9bdbc0f --- /dev/null +++ b/test/30-substitution-redirect.sh @@ -0,0 +1 @@ +echo $(echo foo bar baz 2>/dev/null) diff --git a/test/30-substitution-redirect.stdout b/test/30-substitution-redirect.stdout new file mode 100644 index 0000000..1aeaedb --- /dev/null +++ b/test/30-substitution-redirect.stdout @@ -0,0 +1 @@ +foo bar baz From f3fc92c266d4650d02ef7ffc2ed97426cbc34d08 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 24 Nov 2018 21:05:59 +0100 Subject: [PATCH 266/312] test: add failing redirect/pipe test. --- check.sh | 1 + test/50-redirect-pipe.sh | 1 + test/50-redirect-pipe.stdout | 1 + 3 files changed, 3 insertions(+) create mode 100644 test/50-redirect-pipe.sh create mode 100644 test/50-redirect-pipe.stdout diff --git a/check.sh b/check.sh index 566c1d9..31309a1 100755 --- a/check.sh +++ b/check.sh @@ -88,6 +88,7 @@ tests=' 50-redirect-space 50-redirect-in 50-redirect-append +50-redirect-pipe 60-function 60-subst diff --git a/test/50-redirect-pipe.sh b/test/50-redirect-pipe.sh new file mode 100644 index 0000000..8c809e4 --- /dev/null +++ b/test/50-redirect-pipe.sh @@ -0,0 +1 @@ +echo foo | grep foo 2>/dev/null diff --git a/test/50-redirect-pipe.stdout b/test/50-redirect-pipe.stdout new file mode 100644 index 0000000..257cc56 --- /dev/null +++ b/test/50-redirect-pipe.stdout @@ -0,0 +1 @@ +foo From 2f5de56cfd76abf8bad414c053c44a8809c90831 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 24 Nov 2018 21:57:34 +0100 Subject: [PATCH 267/312] test: add 50-redirect-merge.sh --- check.sh | 1 + test/50-redirect-merge.sh | 5 +++++ test/50-redirect-merge.stdout | 3 +++ 3 files changed, 9 insertions(+) create mode 100644 test/50-redirect-merge.sh create mode 100644 test/50-redirect-merge.stdout diff --git a/check.sh b/check.sh index 31309a1..24463a2 100755 --- a/check.sh +++ b/check.sh @@ -89,6 +89,7 @@ tests=' 50-redirect-in 50-redirect-append 50-redirect-pipe +50-redirect-merge 60-function 60-subst diff --git a/test/50-redirect-merge.sh b/test/50-redirect-merge.sh new file mode 100644 index 0000000..79e7a7c --- /dev/null +++ b/test/50-redirect-merge.sh @@ -0,0 +1,5 @@ +set +e +ls /bin/sh /bin/foo > bar 2>&1 +echo foo +cat bar +rm bar diff --git a/test/50-redirect-merge.stdout b/test/50-redirect-merge.stdout new file mode 100644 index 0000000..4e95736 --- /dev/null +++ b/test/50-redirect-merge.stdout @@ -0,0 +1,3 @@ +foo +ls: cannot access '/bin/foo': No such file or directory +/bin/sh From 7f6b88c43b8c03c9b91743e0e871ccf811d03bbc Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 25 Nov 2018 08:46:10 +0100 Subject: [PATCH 268/312] implement shift. --- check.sh | 1 + gash/builtins.scm | 8 ++++++++ gash/grammar.scm | 2 ++ gash/script.scm | 3 +++ test/01-script-shift.sh | 9 +++++++++ test/01-script-shift.stdout | 5 +++++ 6 files changed, 28 insertions(+) create mode 100644 test/01-script-shift.sh create mode 100644 test/01-script-shift.stdout diff --git a/check.sh b/check.sh index 24463a2..c668304 100755 --- a/check.sh +++ b/check.sh @@ -17,6 +17,7 @@ tests=' 01-script-backslash-twice 01-script-$0 01-script-$@ +01-script-shift 03-echo 03-echo-doublequotes diff --git a/gash/builtins.scm b/gash/builtins.scm index 6be4c95..84235cc 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -54,6 +54,7 @@ jobs-command pwd-command set-command + shift-command )) (define (PATH-search-path program) @@ -118,6 +119,12 @@ (apply set-command (map (cut string-append set <>) (cdr lst))))) ((h ...) (last (map set-command args))))) +(define (shift-command . args) + (lambda _ + (match args + (() (when (pair? (cdr (%command-line))) + (%command-line (cons (car (%command-line)) (cddr (%command-line))))))))) + (define (eval-command . args) (lambda _ (match args @@ -379,6 +386,7 @@ Options: ("jobs" . ,jobs-command) ("pwd" . ,pwd-command) ("set" . ,set-command) + ("shift" . ,shift-command) ("test" . ,test-command) ("type" . ,type-command) ("[" . ,bracket-command) diff --git a/gash/grammar.scm b/gash/grammar.scm index 3c620c3..086a364 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -283,5 +283,7 @@ (('word 'delim) '(word "")) + (('pipeline ('command ('word "shift"))) '(shift)) + ((h t ...) (map transform o)) (_ o))) diff --git a/gash/script.scm b/gash/script.scm index 1a2b5bf..69c5d0f 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -426,3 +426,6 @@ (define (test . o) ;; TODO replace with implementation in scheme (command (cons "test" o))) + +(define (shift . o) + (apply (shift-command) o)) diff --git a/test/01-script-shift.sh b/test/01-script-shift.sh new file mode 100644 index 0000000..216dc45 --- /dev/null +++ b/test/01-script-shift.sh @@ -0,0 +1,9 @@ +echo $@ +shift +echo $@ +shift +echo $@ +shift +echo $@ +shift +echo $@ diff --git a/test/01-script-shift.stdout b/test/01-script-shift.stdout new file mode 100644 index 0000000..2abb895 --- /dev/null +++ b/test/01-script-shift.stdout @@ -0,0 +1,5 @@ +-s --long file0 file1 +--long file0 file1 +file0 file1 +file1 + From 7f2b1b1ff18289df44533e352c5ceb53933c49ff Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 25 Nov 2018 11:48:12 +0100 Subject: [PATCH 269/312] build: Oops, configure SHELLS as shell. --- configure | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/configure b/configure index 5c43d4e..7e647e0 100755 --- a/configure +++ b/configure @@ -80,13 +80,17 @@ subst () { $1 > $2 } -subst bin/gash.in bin/gash -chmod +x bin/gash - SHELLS=" bash +gash sh " + +for shell in $SHELLS; do + subst ${srcdest}bin/gash.in bin/$shell + chmod +x bin/$shell +done + BUILTINS=" basename cat @@ -107,7 +111,7 @@ touch wc which " -for builtin in $BUILTINS $SHELLS; do +for builtin in $BUILTINS; do subst ${srcdest}bin/builtin.in bin/$builtin chmod +x bin/$builtin done From 1162f37d19192017eccd235c2b1fbde2bb6df07b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 25 Nov 2018 11:53:29 +0100 Subject: [PATCH 270/312] test: 07-variable-or-empty. --- check.sh | 1 + gash/environment.scm | 3 ++- gash/grammar.scm | 2 +- test/07-variable-or-empty.sh | 1 + test/07-variable-or-empty.stdout | 1 + 5 files changed, 6 insertions(+), 2 deletions(-) create mode 100644 test/07-variable-or-empty.sh create mode 100644 test/07-variable-or-empty.stdout diff --git a/check.sh b/check.sh index c668304..7c8c6e1 100755 --- a/check.sh +++ b/check.sh @@ -45,6 +45,7 @@ tests=' 07-variable-or-slash 07-variable-or-variable 07-variable-or-doublequote +07-variable-or-empty 08-variable-and 08-variable-not-and diff --git a/gash/environment.scm b/gash/environment.scm index c772e9b..97d02c1 100644 --- a/gash/environment.scm +++ b/gash/environment.scm @@ -41,7 +41,8 @@ ;; FIXME: export/env vs set (define %global-variables (map identity ;; FIXME: make mutable - `(,(cons "SHELLOPTS" "") + `(,(cons "SHELL" (car (command-line))) + ,(cons "SHELLOPTS" "") ,(cons "PIPESTATUS" "([0]=\"0\"") ,(cons "?" "0") ,@(map (lambda (key-value) diff --git a/gash/grammar.scm b/gash/grammar.scm index 086a364..0c5be06 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -139,7 +139,7 @@ variable-subst <- dollar lbrace (variable-or / variable-and / variable-regex) rbrace variable-or <-- name min variable-word variable-word* variable-and <-- name plus variable-word variable-word* - variable-word <- variable-regex / substitution / variable-subst / variable / variable-literal !slash / variable-string + variable-word <- variable-regex / substitution / variable-subst / variable / variable-literal !slash / variable-string / sp* variable-regex <-- name &slash regex-sep variable-literal '/' variable-string &rbrace / name regex-sep variable-string slash < '/' diff --git a/test/07-variable-or-empty.sh b/test/07-variable-or-empty.sh new file mode 100644 index 0000000..ba4f900 --- /dev/null +++ b/test/07-variable-or-empty.sh @@ -0,0 +1 @@ +echo ${bindir-} diff --git a/test/07-variable-or-empty.stdout b/test/07-variable-or-empty.stdout new file mode 100644 index 0000000..8b13789 --- /dev/null +++ b/test/07-variable-or-empty.stdout @@ -0,0 +1 @@ + From 0a09ab114af631f9763459203014ee5208c9058e Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 30 Nov 2018 12:26:28 +0100 Subject: [PATCH 271/312] mv: New builtin. * gash/commands/mv.scm: New file. * gash/bournish-commands.scm: Use it. * build-aux/build-guile.sh: Compile it. * configure: Wrap it. * .gitignore: Ignore it. --- .gitignore | 2 ++ build-aux/build-guile.sh | 2 ++ configure | 1 + gash/bournish-commands.scm | 10 ++++++-- gash/commands/mkdir.scm | 8 +++---- gash/commands/mv.scm | 47 ++++++++++++++++++++++++++++++++++++++ 6 files changed, 64 insertions(+), 6 deletions(-) create mode 100644 gash/commands/mv.scm diff --git a/.gitignore b/.gitignore index 53c658d..c77a12f 100644 --- a/.gitignore +++ b/.gitignore @@ -12,12 +12,14 @@ /bin/grep /bin/ls /bin/mkdir +/bin/mv /bin/reboot /bin/rm /bin/rmdir /bin/sed /bin/sh /bin/tar +/bin/touch /bin/wc /bin/which /.config.make diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index ff32da8..18cc57a 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -66,6 +66,7 @@ ${srcdest}gash/commands/find.scm ${srcdest}gash/commands/grep.scm ${srcdest}gash/commands/ls.scm ${srcdest}gash/commands/mkdir.scm +${srcdest}gash/commands/mv.scm ${srcdest}gash/commands/reboot.scm ${srcdest}gash/commands/rm.scm ${srcdest}gash/commands/rmdir.scm @@ -89,6 +90,7 @@ ${srcdest}bin/gash ${srcdest}bin/grep ${srcdest}bin/ls ${srcdest}bin/mkdir +${srcdest}bin/mv ${srcdest}bin/reboot ${srcdest}bin/rm ${srcdest}bin/rmdir diff --git a/configure b/configure index 7e647e0..9a12bb6 100755 --- a/configure +++ b/configure @@ -102,6 +102,7 @@ find grep ls mkdir +mv reboot rm rmdir diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index e3ac04c..440effe 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -39,6 +39,8 @@ #:use-module (gash commands find) #:use-module (gash commands grep) #:use-module (gash commands ls) + #:use-module (gash commands mkdir) + #:use-module (gash commands mv) #:use-module (gash commands reboot) #:use-module (gash commands rm) #:use-module (gash commands sed) @@ -57,6 +59,8 @@ find-command grep-command ls-command + mkdir-command + mv-command reboot-command rm-command sed-command @@ -86,7 +90,8 @@ (define find-command (wrap-command "find" find)) (define grep-command (wrap-command "grep" grep)) (define ls-command (wrap-command "ls" ls)) -(define mkdir-command (wrap-command "mkdir" mkdir)) +(define mkdir-command (wrap-command "mkdir" mkdir')) +(define mv-command (wrap-command "mv" mv)) (define reboot-command (wrap-command "reboot" reboot')) (define rm-command (wrap-command "rm" rm)) (define rmdir-command (wrap-command "rmdir" rmdir)) @@ -106,7 +111,8 @@ ("find" . ,find-command) ("grep" . ,grep-command) ("ls" . ,ls-command) - ("mkdir" . ,mkdir) + ("mkdir" . ,mkdir-command) + ("mv" . ,mv-command) ("reboot" . ,reboot-command) ("rm" . ,rm-command) ("rmdir" . ,rmdir-command) diff --git a/gash/commands/mkdir.scm b/gash/commands/mkdir.scm index aca721e..c798592 100644 --- a/gash/commands/mkdir.scm +++ b/gash/commands/mkdir.scm @@ -35,10 +35,10 @@ #:use-module (gash shell-utils) #:export ( - mkdir + mkdir' )) -(define (mkdir . args) +(define (mkdir' . args) (let* ((option-spec '((help (single-char #\h)) (mode (single-char #\m) (value #t)) @@ -67,8 +67,8 @@ Options: ") (exit (if usage? 2 0))) (else - (let ((mode (if mode (umask (chmodifiers->mode (parse-modifiers mode))) + (let ((mode (if mode (umask (chmodifiers->mode (parse-chmodifiers mode))) #o755))) (for-each (if parents? mkdir-p (@ (guile) mkdir)) files)))))) -(define main mkdir) +(define main mkdir') diff --git a/gash/commands/mv.scm b/gash/commands/mv.scm new file mode 100644 index 0000000..5c60c01 --- /dev/null +++ b/gash/commands/mv.scm @@ -0,0 +1,47 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; Code: + +(define-module (gash commands mv) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:use-module (gash config) + #:use-module (gash shell-utils) + #:export ( + mv + )) + +(define (mv name . args) + (match args + ((or "-h" "--help") + (format #t "mv SOURCE... DEST\n")) + ((or "-V" "--version") + (format #t "mv (GASH) ~a\n" %version) (exit 0)) + ((source dest) + (rename-file source dest)) + ((sources ... dest) + (unless (directory-exists? dest) + (error (format #f "mv: target `~a' is not a directory\n" dest))) + (for-each rename-file + sources + (map (cut string-append dest "/" <>) sources))))) + +(define main mv) From 298238e8e6409ec94e852dab2cdac70fbcd139be Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 30 Nov 2018 12:32:00 +0100 Subject: [PATCH 272/312] guix: Update build. --- guix.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/guix.scm b/guix.scm index 9123d94..ea3178f 100644 --- a/guix.scm +++ b/guix.scm @@ -81,7 +81,7 @@ (define-public guile-gash (let ((version "0.1") - (commit "cb8671f3125b8acbfdc28a9ab169a2e8c38b2a49") + (commit "0a09ab114af631f9763459203014ee5208c9058e") (revision "0") (builtins '( "basename" @@ -94,13 +94,14 @@ "grep" "ls" "mkdir" + "mv" "reboot" "rm" "rmdir" "sed" "tar" "touch" - "wc " + "wc" "which" )) (shells '("bash" "gash" "sh"))) @@ -114,7 +115,7 @@ "/gash-" commit ".tar.gz")) (sha256 (base32 - "1i51qz4xl6ija77jrjdq5r3y4p0jl3kzii1d7i3kyd8rydxycgj5")))) + "0986yd6y8jnsbwn5mx6y3ihc0x6mm79qq41ny6c6m1h402n6rw0n")))) (build-system guile-build-system) (arguments `(#:phases From 8f12c6a5621c84f25b400b70b7660319d0a5ed81 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 30 Nov 2018 14:17:46 +0100 Subject: [PATCH 273/312] test: 50-redirect-sed.sh --- check.sh | 1 + test/50-redirect-sed.sh | 5 +++++ test/50-redirect-sed.stdout | 3 +++ test/data/diff.scm | 3 +++ 4 files changed, 12 insertions(+) create mode 100644 test/50-redirect-sed.sh create mode 100644 test/50-redirect-sed.stdout create mode 100644 test/data/diff.scm diff --git a/check.sh b/check.sh index 7c8c6e1..c1b6836 100755 --- a/check.sh +++ b/check.sh @@ -92,6 +92,7 @@ tests=' 50-redirect-append 50-redirect-pipe 50-redirect-merge +50-redirect-sed 60-function 60-subst diff --git a/test/50-redirect-sed.sh b/test/50-redirect-sed.sh new file mode 100644 index 0000000..754d581 --- /dev/null +++ b/test/50-redirect-sed.sh @@ -0,0 +1,5 @@ +sed \ + -e "s,^#! /bin/sh,#! /bin/gash," \ + test/data/diff.scm > $DESTDIR/tmp/diff.scm +cat $DESTDIR/tmp/diff.scm +rm $DESTDIR/tmp/diff.scm diff --git a/test/50-redirect-sed.stdout b/test/50-redirect-sed.stdout new file mode 100644 index 0000000..800bdd8 --- /dev/null +++ b/test/50-redirect-sed.stdout @@ -0,0 +1,3 @@ +#! /bin/gash +!# + diff --git a/test/data/diff.scm b/test/data/diff.scm new file mode 100644 index 0000000..c7efd07 --- /dev/null +++ b/test/data/diff.scm @@ -0,0 +1,3 @@ +#! /bin/sh +!# + From 380562c0b3ed276540dab1abab41a52d17384a69 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 30 Nov 2018 16:36:00 +0100 Subject: [PATCH 274/312] test: 100-test-file, 100-bracket-file. --- check.sh | 4 ++++ test/100-bracket-file.sh | 4 ++++ test/100-test-file.sh | 4 ++++ 3 files changed, 12 insertions(+) create mode 100644 test/100-bracket-file.sh create mode 100644 test/100-test-file.sh diff --git a/check.sh b/check.sh index c1b6836..78cab44 100755 --- a/check.sh +++ b/check.sh @@ -109,6 +109,9 @@ tests=' 100-cd 100-cd-foo +100-test-file +100-bracket-file + 100-sed 100-sed-once 100-sed-global @@ -123,6 +126,7 @@ tests=' 100-tar-Z 100-tar-Z-old 100-tar-Z-pipe + ' broken=" diff --git a/test/100-bracket-file.sh b/test/100-bracket-file.sh new file mode 100644 index 0000000..e563697 --- /dev/null +++ b/test/100-bracket-file.sh @@ -0,0 +1,4 @@ +if [ -f foo-bar ]; then + exit 1 +fi + diff --git a/test/100-test-file.sh b/test/100-test-file.sh new file mode 100644 index 0000000..ebf0f4c --- /dev/null +++ b/test/100-test-file.sh @@ -0,0 +1,4 @@ +if test -f foo-bar; then + exit 1 +fi + From 157bd5162dbc7ffb8fbc5c53287b458ab568379b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 30 Nov 2018 19:06:06 +0100 Subject: [PATCH 275/312] test: 10-if-line.sh. Adding a newline to this file will no longer reproduce this bug. --- test/10-if-line.sh | 1 + 1 file changed, 1 insertion(+) create mode 100644 test/10-if-line.sh diff --git a/test/10-if-line.sh b/test/10-if-line.sh new file mode 100644 index 0000000..da0e6d8 --- /dev/null +++ b/test/10-if-line.sh @@ -0,0 +1 @@ +if true; then echo yay; fi \ No newline at end of file From 8b925dd5e835e746b4e6958b6dce95ca33ca940d Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 1 Dec 2018 08:00:12 +0100 Subject: [PATCH 276/312] test: 03-echo-brace. --- check.sh | 1 + test/03-echo-brace.sh | 1 + test/03-echo-brace.stdout | 1 + 3 files changed, 3 insertions(+) create mode 100644 test/03-echo-brace.sh create mode 100644 test/03-echo-brace.stdout diff --git a/check.sh b/check.sh index 78cab44..00e0850 100755 --- a/check.sh +++ b/check.sh @@ -24,6 +24,7 @@ tests=' 03-echo-nesting 03-echo-escaped-doublequotes 03-echo-quoted-doublequotes +03-echo-brace 04-echo-var 04-echo-equal diff --git a/test/03-echo-brace.sh b/test/03-echo-brace.sh new file mode 100644 index 0000000..5e11003 --- /dev/null +++ b/test/03-echo-brace.sh @@ -0,0 +1 @@ +echo foo:{bar} diff --git a/test/03-echo-brace.stdout b/test/03-echo-brace.stdout new file mode 100644 index 0000000..4f1b6f1 --- /dev/null +++ b/test/03-echo-brace.stdout @@ -0,0 +1 @@ +foo:{bar} From d2d799a2f9591a7cc21bfcbcaeb6b1dae2ecc60f Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 1 Dec 2018 08:03:04 +0100 Subject: [PATCH 277/312] test: 20-exec. --- check.sh | 1 + test/20-exec.sh | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 test/20-exec.sh diff --git a/check.sh b/check.sh index 00e0850..50b78a2 100755 --- a/check.sh +++ b/check.sh @@ -70,6 +70,7 @@ tests=' 20-pipe-exit-0 20-pipe-exit-1 20-pipe-sed +20-exec 30-substitution 30-substitution-backtick diff --git a/test/20-exec.sh b/test/20-exec.sh new file mode 100644 index 0000000..8bd0061 --- /dev/null +++ b/test/20-exec.sh @@ -0,0 +1,2 @@ +exec true +false From 932339a5eb17bd435c5f7802201d71d6a2193079 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 1 Dec 2018 08:19:28 +0100 Subject: [PATCH 278/312] test: 30-substitution-word. --- check.sh | 1 + test/30-substitution-word.sh | 2 ++ test/30-substitution-word.stdout | 1 + 3 files changed, 4 insertions(+) create mode 100644 test/30-substitution-word.sh create mode 100644 test/30-substitution-word.stdout diff --git a/check.sh b/check.sh index 50b78a2..b843b67 100755 --- a/check.sh +++ b/check.sh @@ -73,6 +73,7 @@ tests=' 20-exec 30-substitution +30-substitution-word 30-substitution-backtick 30-substitution-assignment 30-for-substitution diff --git a/test/30-substitution-word.sh b/test/30-substitution-word.sh new file mode 100644 index 0000000..69467ab --- /dev/null +++ b/test/30-substitution-word.sh @@ -0,0 +1,2 @@ +echo foo $(echo bar)/baz + diff --git a/test/30-substitution-word.stdout b/test/30-substitution-word.stdout new file mode 100644 index 0000000..1a1c7ad --- /dev/null +++ b/test/30-substitution-word.stdout @@ -0,0 +1 @@ +foo bar/baz From 6852e24dc44e798f282c5a353b80fc569213fd3c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 1 Dec 2018 08:42:15 +0100 Subject: [PATCH 279/312] test: 00-exit-error, 00-exit-var. --- check.sh | 2 ++ test/00-exit-error.exit | 1 + test/00-exit-error.sh | 2 ++ test/00-exit-var.exit | 1 + test/00-exit-var.sh | 3 +++ 5 files changed, 9 insertions(+) create mode 100644 test/00-exit-error.exit create mode 100644 test/00-exit-error.sh create mode 100644 test/00-exit-var.exit create mode 100644 test/00-exit-var.sh diff --git a/check.sh b/check.sh index b843b67..64bd500 100755 --- a/check.sh +++ b/check.sh @@ -9,6 +9,8 @@ tests=' 00-exit-0 00-exit-1 00-exit-2 +00-exit-error +00-exit-var 01-script-newline 01-script-semi diff --git a/test/00-exit-error.exit b/test/00-exit-error.exit new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/test/00-exit-error.exit @@ -0,0 +1 @@ +2 diff --git a/test/00-exit-error.sh b/test/00-exit-error.sh new file mode 100644 index 0000000..aabd2d2 --- /dev/null +++ b/test/00-exit-error.sh @@ -0,0 +1,2 @@ +set +e +ls /foo diff --git a/test/00-exit-var.exit b/test/00-exit-var.exit new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/test/00-exit-var.exit @@ -0,0 +1 @@ +2 diff --git a/test/00-exit-var.sh b/test/00-exit-var.sh new file mode 100644 index 0000000..47b099a --- /dev/null +++ b/test/00-exit-var.sh @@ -0,0 +1,3 @@ +set +e +ls /foo +exit $? From ddc0f58896637fd0974bc1eed7915d28dc17df17 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 1 Dec 2018 09:38:09 +0100 Subject: [PATCH 280/312] test: 01-script-$#, 60-function-at. --- check.sh | 2 ++ test/01-script-$#.sh | 1 + test/01-script-$#.stdout | 1 + test/60-function-at.sh | 8 ++++++++ test/60-function-at.stdout | 4 ++++ 5 files changed, 16 insertions(+) create mode 100644 test/01-script-$#.sh create mode 100644 test/01-script-$#.stdout create mode 100644 test/60-function-at.sh create mode 100644 test/60-function-at.stdout diff --git a/check.sh b/check.sh index 64bd500..a7482df 100755 --- a/check.sh +++ b/check.sh @@ -18,6 +18,7 @@ tests=' 01-script-backslash-space 01-script-backslash-twice 01-script-$0 +01-script-$# 01-script-$@ 01-script-shift @@ -100,6 +101,7 @@ tests=' 50-redirect-sed 60-function +60-function-at 60-subst 70-hash diff --git a/test/01-script-$#.sh b/test/01-script-$#.sh new file mode 100644 index 0000000..bb03f7a --- /dev/null +++ b/test/01-script-$#.sh @@ -0,0 +1 @@ +echo $# diff --git a/test/01-script-$#.stdout b/test/01-script-$#.stdout new file mode 100644 index 0000000..b8626c4 --- /dev/null +++ b/test/01-script-$#.stdout @@ -0,0 +1 @@ +4 diff --git a/test/60-function-at.sh b/test/60-function-at.sh new file mode 100644 index 0000000..e16cc62 --- /dev/null +++ b/test/60-function-at.sh @@ -0,0 +1,8 @@ +foo () { + echo $#:$@ + echo 0:$0 + echo 1:$1 + echo 2:$2 +} + +foo -v $@ diff --git a/test/60-function-at.stdout b/test/60-function-at.stdout new file mode 100644 index 0000000..4c6f217 --- /dev/null +++ b/test/60-function-at.stdout @@ -0,0 +1,4 @@ +5:-v -s --long file0 file1 +0:test/60-function-at.sh +1:-v +2:-s From 6cf9cf7d0f2ec440c8c829385dbbfc0c9fbd94f2 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 1 Dec 2018 09:42:40 +0100 Subject: [PATCH 281/312] test: 10-if-test, 10-if-test-false, 10-if-bracket, 10-if-bracket-false. --- check.sh | 4 ++++ test/10-if-bracket-false.sh | 4 ++++ test/10-if-bracket.sh | 4 ++++ test/10-if-test-false.sh | 4 ++++ test/10-if-test.sh | 4 ++++ 5 files changed, 20 insertions(+) create mode 100644 test/10-if-bracket-false.sh create mode 100644 test/10-if-bracket.sh create mode 100644 test/10-if-test-false.sh create mode 100644 test/10-if-test.sh diff --git a/check.sh b/check.sh index a7482df..3f10cfa 100755 --- a/check.sh +++ b/check.sh @@ -61,6 +61,10 @@ tests=' 10-if-else 10-else-multiple 10-if-elif +10-if-test +10-if-test-false +10-if-bracket +10-if-bracket-false 10-if-redirect 11-for diff --git a/test/10-if-bracket-false.sh b/test/10-if-bracket-false.sh new file mode 100644 index 0000000..acac19b --- /dev/null +++ b/test/10-if-bracket-false.sh @@ -0,0 +1,4 @@ +if [ 0 = 1 ]; then + exit 1 +fi +exit 0 diff --git a/test/10-if-bracket.sh b/test/10-if-bracket.sh new file mode 100644 index 0000000..94b7579 --- /dev/null +++ b/test/10-if-bracket.sh @@ -0,0 +1,4 @@ +if [ 1 = 1 ]; then + exit 0 +fi +exit 1 diff --git a/test/10-if-test-false.sh b/test/10-if-test-false.sh new file mode 100644 index 0000000..220020b --- /dev/null +++ b/test/10-if-test-false.sh @@ -0,0 +1,4 @@ +if test 0 = 1; then + exit 1 +fi +exit 0 diff --git a/test/10-if-test.sh b/test/10-if-test.sh new file mode 100644 index 0000000..8a93e47 --- /dev/null +++ b/test/10-if-test.sh @@ -0,0 +1,4 @@ +if test 1 = 1; then + exit 0 +fi +exit 1 From d5c94e75ddd8d45817787d3ccc0211ad5581448a Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 1 Dec 2018 10:15:33 +0100 Subject: [PATCH 282/312] parse [ .. ] into plain command. fixes 10-if-bracket-false, 100-bracket-file. --- gash/grammar.scm | 8 +++++--- gash/script.scm | 5 ++--- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index 0c5be06..5e096a1 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -115,9 +115,8 @@ until-clause <-- until-keyword compound do-group - test <-- ltest sp+ (word sp+)+ rtest# - ltest < '[' - rtest < ']' + test <- '[' sp+ test-args sp+ ']'# + test-args <-- (sp* word)+ literal <- !reserved (escaped / !allowed .)+ escaped <- escape [ \"$] @@ -285,5 +284,8 @@ (('pipeline ('command ('word "shift"))) '(shift)) + (('command ('word "[" ('test-args test-args ...) "]")) + `(command (word "[") ,@(map transform test-args) (word "]"))) + ((h t ...) (map transform o)) (_ o))) diff --git a/gash/script.scm b/gash/script.scm index 69c5d0f..ae03419 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -96,6 +96,8 @@ escape-builtin?)) (lambda _ (status:exit-val (apply system* command)))))) (else (lambda () #t)))) + (when (> %debug-level 1) + (format (current-error-port) "command: ~s\n" args)) (match args (((or "." "source") file-name) (let* ((string (with-input-from-file file-name read-string)) @@ -424,8 +426,5 @@ (define (regex-sep o) o) -(define (test . o) ;; TODO replace with implementation in scheme - (command (cons "test" o))) - (define (shift . o) (apply (shift-command) o)) From 1f0a7674d9b119fa371135b3e3889a74779b28c2 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 2 Dec 2018 09:02:10 +0100 Subject: [PATCH 283/312] fix 01-script-$#. --- gash/environment.scm | 2 +- gash/grammar.scm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/gash/environment.scm b/gash/environment.scm index 97d02c1..7bff897 100644 --- a/gash/environment.scm +++ b/gash/environment.scm @@ -71,7 +71,7 @@ ((equal? name "@") (string-join (cdr (%command-line)))) ((equal? name "#") - (number->string (length (%command-line)))) + (number->string (length (cdr (%command-line))))) (else (or (assoc-ref %global-variables name) (if (shell-opt? "nounset") (begin diff --git a/gash/grammar.scm b/gash/grammar.scm index 5e096a1..b7c7caa 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -133,7 +133,7 @@ rpar < ')' bt < [`] - variable <-- dollar ('*' / '@' / [0-9] / name / + variable <-- dollar ('#' / '@' / '*' / [0-9] / name / lbrace name (variable-literal / &rbrace) rbrace) variable-subst <- dollar lbrace (variable-or / variable-and / variable-regex) rbrace variable-or <-- name min variable-word variable-word* From 73ecccef1e4a20cc4feda549d01f335ebdd2451c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 1 Dec 2018 10:40:20 +0100 Subject: [PATCH 284/312] fix 01-script-$@. --- check.sh | 1 + gash/environment.scm | 17 ++++++++++------- gash/script.scm | 11 +++++++++-- test/30-substitution-assignment-at.sh | 2 ++ test/30-substitution-assignment-at.stdout | 1 + 5 files changed, 23 insertions(+), 9 deletions(-) create mode 100644 test/30-substitution-assignment-at.sh create mode 100644 test/30-substitution-assignment-at.stdout diff --git a/check.sh b/check.sh index 3f10cfa..c5693ec 100755 --- a/check.sh +++ b/check.sh @@ -85,6 +85,7 @@ tests=' 30-substitution-assignment 30-for-substitution 30-substitution-assignment +30-substitution-assignment-at 30-substitution-redirect 40-eval diff --git a/gash/environment.scm b/gash/environment.scm index 7bff897..66b0381 100644 --- a/gash/environment.scm +++ b/gash/environment.scm @@ -21,6 +21,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (ice-9 match) #:use-module (gash io) #:export ( @@ -55,12 +56,13 @@ (define %functions '()) (define* (assignment name #:optional value) - (if value - (set! %global-variables - (assoc-set! %global-variables name value)) - (set! %global-variables - (assoc-set! %global-variables name ""))) - #t) + (let ((value (match value + ((? string?) value) + (((? string?) ...) (apply string-append value)) + (#f "")))) + (set! %global-variables + (assoc-set! %global-variables name value)) + #t)) (define* (variable name #:optional (default "")) (cond ((string->number name) @@ -69,7 +71,8 @@ (if (< n (length (%command-line))) (list-ref (%command-line) n) ""))) ((equal? name "@") - (string-join (cdr (%command-line)))) + (if (pair? (cdr (%command-line))) (cdr (%command-line)) + "")) ((equal? name "#") (number->string (length (cdr (%command-line))))) (else diff --git a/gash/script.scm b/gash/script.scm index ae03419..8a2e226 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -104,6 +104,9 @@ (ast (parse-string string))) (run ast) 0)) + (((? string?) ..1) (exec (append-map glob args))) + (((and (or (? string?)) c) ((and (? string?) a) ...)) + (exec (append-map glob (cons c a)))) (_ (exec (append-map glob args))))) (define (glob? pattern) @@ -180,6 +183,7 @@ (_ (list o)))) (match o (((? string?) ...) (string-join (flatten o) "")) + ((((? string?) ...)) (flatten (car o))) (_ o))) (define-syntax-rule (substitution commands) @@ -417,8 +421,11 @@ ((h ... t) t) (_ o))) -(define (delim . o) - (string-join o "")) +(define (delim o . rest) + (match rest + (() o) + (((? string?) ...) (string-append o (string-join rest ""))) + ((((? string?) ...)) (string-append o (string-join (car rest) ""))))) (define (name o) o) diff --git a/test/30-substitution-assignment-at.sh b/test/30-substitution-assignment-at.sh new file mode 100644 index 0000000..a888fd0 --- /dev/null +++ b/test/30-substitution-assignment-at.sh @@ -0,0 +1,2 @@ +cmdline=$(echo " $@") +echo cmdline:$cmdline diff --git a/test/30-substitution-assignment-at.stdout b/test/30-substitution-assignment-at.stdout new file mode 100644 index 0000000..0f794c3 --- /dev/null +++ b/test/30-substitution-assignment-at.stdout @@ -0,0 +1 @@ +cmdline: -s --long file0 file1 From 0679cf9903e827057035e22b4a8853b324360bb1 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 1 Dec 2018 14:00:05 +0100 Subject: [PATCH 285/312] mv: Support -f, --force (by ignoring it). --- gash/commands/mv.scm | 34 +++++++++++++++++++++++++--------- 1 file changed, 25 insertions(+), 9 deletions(-) diff --git a/gash/commands/mv.scm b/gash/commands/mv.scm index 5c60c01..724bf4e 100644 --- a/gash/commands/mv.scm +++ b/gash/commands/mv.scm @@ -30,18 +30,34 @@ )) (define (mv name . args) + (define (usage port) + (display "Usage: mv [OPTION]... SOURCE... DEST + +Options: + -f, --force ignored for compatibility + -h, --help display this help and exit + -V, --version display version information and exit +" port)) (match args - ((or "-h" "--help") - (format #t "mv SOURCE... DEST\n")) - ((or "-V" "--version") + (((or "-f" "--force") args ...) + (apply mv (cons name args))) + (((or "-h" "--help") t ...) + (usage (current-output-port)) + (exit 0)) + (((or "-V" "--version") t ...) (format #t "mv (GASH) ~a\n" %version) (exit 0)) + ((source (and (? directory-exists?) dir)) + (rename-file source (string-append dir "/" (basename source)))) ((source dest) (rename-file source dest)) - ((sources ... dest) - (unless (directory-exists? dest) - (error (format #f "mv: target `~a' is not a directory\n" dest))) - (for-each rename-file - sources - (map (cut string-append dest "/" <>) sources))))) + ((sources ... dir) + (unless (directory-exists? dir) + (error (format #f "mv: target `~a' is not a directory\n" dir))) + (for-each + rename-file + sources + (map (compose (cute string-append dir "/" <>) basename) + sources))) + (_ (usage (current-error-port)) (exit 2)))) (define main mv) From 353af765eb36941eca6423d95b524f9cf999ad75 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 1 Dec 2018 14:31:53 +0100 Subject: [PATCH 286/312] cp: Support -f, --force. --- gash/commands/cp.scm | 52 ++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 50 insertions(+), 2 deletions(-) diff --git a/gash/commands/cp.scm b/gash/commands/cp.scm index 62baee6..69ad1d4 100644 --- a/gash/commands/cp.scm +++ b/gash/commands/cp.scm @@ -26,11 +26,59 @@ ;;; Code: (define-module (gash commands cp) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:use-module (gash config) + #:use-module (gash shell-utils) #:export ( cp )) -(define (cp name source dest . rest) - (copy-file source dest)) +(define (copy-file-force? force?) + (lambda (src dest) + (if (not force?) (copy-file src dest) + (catch 'system-error + (lambda _ + (copy-file src dest)) + (lambda (key func fmt msg errno . rest) + (format #t "errno:~s\n" (car errno)) + (match errno + ((13) + (delete-file dest) + (copy-file src dest)) + (_ (throw key func fmt msg errno)))))))) + +(define (cp name . args) + (define (usage port) + (display "Usage: cp [OPTION]... SOURCE... DEST + +Options: + -f, --force if an existing destination file cannot be opened, + remove it and try again + -h, --help display this help and exit + -V, --version display version information and exit +" port)) + (match args + (((or "-f" "--force") args ...) + (apply cp (cons 'force args))) + (((or "-h" "--help") t ...) + (usage (current-output-port)) + (exit 0)) + (((or "-V" "--version") t ...) + (format #t "cp (GASH) ~a\n" %version) (exit 0)) + ((source (and (? directory-exists?) dir)) + ((copy-file-force? (eq? name 'force)) + source (string-append dir "/" (basename source)))) + ((source dest) + ((copy-file-force? (eq? name 'force)) source dest)) + ((sources ... dir) + (unless (directory-exists? dir) + (error (format #f "mv: target `~a' is not a directory\n" dir))) + (for-each + (copy-file-force? (eq? name 'force)) + sources + (map (compose (cute string-append dir "/" <>) basename) + sources))) + (_ (usage (current-error-port)) (exit 2)))) (define main cp) From a043f9ef0928e7eb62ff5fbcba282b7eaa2fecea Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 1 Dec 2018 22:48:57 +0100 Subject: [PATCH 287/312] tr: New builtin. * gash/commands/tr.scm: New file. * gash/bournish-commands.scm: Use it. * build-aux/build-guile.sh: Compile it. * configure: Wrap it. * .gitignore: Ignore it. --- .gitignore | 1 + build-aux/build-guile.sh | 2 + configure | 1 + gash/bournish-commands.scm | 4 ++ gash/commands/tr.scm | 75 ++++++++++++++++++++++++++++++++++++++ 5 files changed, 83 insertions(+) create mode 100644 gash/commands/tr.scm diff --git a/.gitignore b/.gitignore index c77a12f..c32430d 100644 --- a/.gitignore +++ b/.gitignore @@ -20,6 +20,7 @@ /bin/sh /bin/tar /bin/touch +/bin/tr /bin/wc /bin/which /.config.make diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 18cc57a..91e1a0c 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -73,6 +73,7 @@ ${srcdest}gash/commands/rmdir.scm ${srcdest}gash/commands/sed.scm ${srcdest}gash/commands/tar.scm ${srcdest}gash/commands/touch.scm +${srcdest}gash/commands/tr.scm ${srcdest}gash/commands/wc.scm ${srcdest}gash/commands/which.scm @@ -97,6 +98,7 @@ ${srcdest}bin/rmdir ${srcdest}bin/sed ${srcdest}bin/tar ${srcdest}bin/touch +${srcdest}bin/tr ${srcdest}bin/wc ${srcdest}bin/which " diff --git a/configure b/configure index 9a12bb6..acc3b2c 100755 --- a/configure +++ b/configure @@ -109,6 +109,7 @@ rmdir sed tar touch +tr wc which " diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 440effe..6b448bb 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -46,6 +46,7 @@ #:use-module (gash commands sed) #:use-module (gash commands tar) #:use-module (gash commands touch) + #:use-module (gash commands tr) #:use-module (gash commands wc) #:use-module (gash commands which) @@ -66,6 +67,7 @@ sed-command tar-command touch-command + tr-command rm-command wc-command which-command @@ -98,6 +100,7 @@ (define sed-command (wrap-command "sed" sed)) (define tar-command (wrap-command "tar" tar)) (define touch-command (wrap-command "touch" touch)) +(define tr-command (wrap-command "tr" tr)) (define wc-command (wrap-command "wc" wc)) (define which-command (wrap-command "which" which)) @@ -119,6 +122,7 @@ ("sed" . ,sed-command) ("tar" . ,tar-command) ("touch" . ,touch-command) + ("tr" . ,tr-command) ("wc" . ,wc-command) ("which" . ,which-command) )) diff --git a/gash/commands/tr.scm b/gash/commands/tr.scm new file mode 100644 index 0000000..796f632 --- /dev/null +++ b/gash/commands/tr.scm @@ -0,0 +1,75 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; Code: + +(define-module (gash commands tr) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 rdelim) + #:use-module (gash config) + #:export ( + tr + )) + +(define (string-replace-string string from to) + (cond ((string-contains string from) + => + (lambda (i) + (string-replace string to i (+ i (string-length from))))) + (else string))) + +(define (tr . args) + (let* ((option-spec + '((delete (single-char #\d)) + (help (single-char #\h)) + (version (single-char #\V)))) + (options (getopt-long args option-spec)) + (delete? (option-ref options 'delete #f)) + (files (option-ref options '() '())) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (usage? (and (not help?) (not (or (and delete? (= (length files) 1)) + (= (length files) 2)))))) + (cond (version? (format #t "tr (GASH) ~a\n" %version) (exit 0)) + ((or help? usage?) (format (if usage? (current-error-port) #t) + "\ +Usage: tr [OPTION]... SET1 [SET2] + +Options: + -d, --delete delete characters in SET1, do not translate + -h, --help display this help and exit + -V, --version display version information and exit +") + (exit (if usage? 2 0))) + (delete? + (let* ((s (car files)) + (s (string-replace-string s "\\n" "\n")) + (s (string-replace-string s "\\r" "\r")) + (s (string-replace-string s "\\t" "\t")) + (s (string->char-set s))) + (let loop ((line (read-line (current-input-port) 'concat))) + (if (eof-object? line) #t + (begin + (display (string-delete s line)) + (loop (read-line (current-input-port) 'concat))))))) + (else + (format #t "TODO: TR A B\n"))))) + +(define main tr) From 2c3630cfedd1554ad0365f32d1163437e8e37a3e Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 2 Dec 2018 07:15:45 +0100 Subject: [PATCH 288/312] test: 50-redirect-in-out, 100-tr. --- check.sh | 2 ++ test/100-tr.sh | 1 + test/100-tr.stdout | 3 +++ test/50-redirect-in-out.sh | 3 +++ test/50-redirect-in-out.stdout | 3 +++ 5 files changed, 12 insertions(+) create mode 100644 test/100-tr.sh create mode 100644 test/100-tr.stdout create mode 100644 test/50-redirect-in-out.sh create mode 100644 test/50-redirect-in-out.stdout diff --git a/check.sh b/check.sh index c5693ec..0d4e017 100755 --- a/check.sh +++ b/check.sh @@ -104,6 +104,7 @@ tests=' 50-redirect-pipe 50-redirect-merge 50-redirect-sed +50-redirect-in-out 60-function 60-function-at @@ -139,6 +140,7 @@ tests=' 100-tar-Z-old 100-tar-Z-pipe +100-tr ' broken=" diff --git a/test/100-tr.sh b/test/100-tr.sh new file mode 100644 index 0000000..70a5b38 --- /dev/null +++ b/test/100-tr.sh @@ -0,0 +1 @@ +\tr -d o < test/data/foo diff --git a/test/100-tr.stdout b/test/100-tr.stdout new file mode 100644 index 0000000..5c2d6f2 --- /dev/null +++ b/test/100-tr.stdout @@ -0,0 +1,3 @@ +f +bar +baz diff --git a/test/50-redirect-in-out.sh b/test/50-redirect-in-out.sh new file mode 100644 index 0000000..bf2c1ec --- /dev/null +++ b/test/50-redirect-in-out.sh @@ -0,0 +1,3 @@ +cat < test/data/foo > bar +cat bar +rm bar diff --git a/test/50-redirect-in-out.stdout b/test/50-redirect-in-out.stdout new file mode 100644 index 0000000..86e041d --- /dev/null +++ b/test/50-redirect-in-out.stdout @@ -0,0 +1,3 @@ +foo +bar +baz From f5bc1d45c4871ac9ca9e571e4ad0903bb73b46c2 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 1 Dec 2018 21:48:48 +0100 Subject: [PATCH 289/312] fix: 50-redirect-in-out. --- gash/grammar.scm | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index b7c7caa..5473fff 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -250,12 +250,22 @@ `(pipeline (cut display ,string) (command ,@word))) (('command word ... ('io-redirect filedes ... ('io-file ">" file-name))) (cond ((or (null? filedes) (equal? filedes '("1"))) - `(with-output-to-file ,file-name (command ,@word))) + `(with-output-to-file ,file-name + ,(let ((command (transform `(command ,@word)))) + (match command + (('with-input-from-file arg ...) + `(cut with-input-from-file ,@arg)) + (_ command))))) ((equal? filedes '("2")) - `(with-error-to-file ,file-name (command ,@word))) + `(with-error-to-file ,file-name + ,(let ((command (transform `(command ,@word)))) + (match command + (('with-input-from-file arg ...) + `(cut with-input-from-file ,@arg)) + (_ command))))) (else (error (format #f "TODO: output to filedes=~a\n" filedes))))) (('command word ... ('io-redirect ('io-file "<" file-name))) - `(with-input-from-file ,file-name (command ,@word))) + `(with-input-from-file ,file-name ,(transform `(command ,@word)))) (('command ('word (and (? string?) string)) ...) `(command ,@string)) From 9115b9fbb65fc43a635711051ede65c9d3338b46 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 2 Dec 2018 07:35:13 +0100 Subject: [PATCH 290/312] test: 100-sed-fooRbar. --- check.sh | 1 + test/100-sed-fooRbar.sh | 1 + test/100-sed-fooRbar.stdout | 3 +++ test/data/fooRbar | 2 ++ 4 files changed, 7 insertions(+) create mode 100644 test/100-sed-fooRbar.sh create mode 100644 test/100-sed-fooRbar.stdout create mode 100644 test/data/fooRbar diff --git a/check.sh b/check.sh index 0d4e017..8ed8675 100755 --- a/check.sh +++ b/check.sh @@ -134,6 +134,7 @@ tests=' 100-sed-twice 100-sed-undo 100-sed-file +100-sed-fooRbar 100-tar 100-tar-Z diff --git a/test/100-sed-fooRbar.sh b/test/100-sed-fooRbar.sh new file mode 100644 index 0000000..3e31a92 --- /dev/null +++ b/test/100-sed-fooRbar.sh @@ -0,0 +1 @@ +\sed s",\r,\n," < test/data/fooRbar diff --git a/test/100-sed-fooRbar.stdout b/test/100-sed-fooRbar.stdout new file mode 100644 index 0000000..c38c3d6 --- /dev/null +++ b/test/100-sed-fooRbar.stdout @@ -0,0 +1,3 @@ +foo\rbar +foo +bar diff --git a/test/data/fooRbar b/test/data/fooRbar new file mode 100644 index 0000000..6bb06cc --- /dev/null +++ b/test/data/fooRbar @@ -0,0 +1,2 @@ +foo\rbar +foo bar From 632295fa183dbfd97fdd598f6b5a864df1c78f45 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 2 Dec 2018 07:35:50 +0100 Subject: [PATCH 291/312] fix: 100-sed-fooRbar. --- gash/commands/sed.scm | 4 ++++ gash/commands/tr.scm | 8 +------- gash/util.scm | 8 ++++++++ 3 files changed, 13 insertions(+), 7 deletions(-) diff --git a/gash/commands/sed.scm b/gash/commands/sed.scm index cb10bc1..1d55117 100644 --- a/gash/commands/sed.scm +++ b/gash/commands/sed.scm @@ -29,6 +29,7 @@ #:use-module (gash config) #:use-module (gash guix-utils) #:use-module (gash shell-utils) + #:use-module (gash util) #:export ( sed @@ -114,6 +115,9 @@ Usage: sed [OPTION]... [SCRIPT] [FILE]... (cond ((string-prefix? "s" o) (let* ((command (substring o 1)) (string (substring command 1)) + (string (string-replace-string string "\\n" "\n")) + (string (string-replace-string string "\\r" "\r")) + (string (string-replace-string string "\\t" "\t")) (separator (string-ref command 0))) (receive (search replace modifier-string) (apply values (string-split string separator)) diff --git a/gash/commands/tr.scm b/gash/commands/tr.scm index 796f632..20eaa93 100644 --- a/gash/commands/tr.scm +++ b/gash/commands/tr.scm @@ -24,17 +24,11 @@ #:use-module (ice-9 getopt-long) #:use-module (ice-9 rdelim) #:use-module (gash config) + #:use-module (gash util) #:export ( tr )) -(define (string-replace-string string from to) - (cond ((string-contains string from) - => - (lambda (i) - (string-replace string to i (+ i (string-length from))))) - (else string))) - (define (tr . args) (let* ((option-spec '((delete (single-char #\d)) diff --git a/gash/util.scm b/gash/util.scm index 2da6d37..908725e 100644 --- a/gash/util.scm +++ b/gash/util.scm @@ -27,6 +27,7 @@ wrap-command char->string string->string-list + string-replace-string )) (define (disjoin . predicates) @@ -42,3 +43,10 @@ (define (char->string c) (make-string 1 c)) + +(define (string-replace-string string from to) + (cond ((string-contains string from) + => + (lambda (i) + (string-replace string to i (+ i (string-length from))))) + (else string))) From 39761c00874b745fbe01ac8bd897450391f72589 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 2 Dec 2018 09:42:35 +0100 Subject: [PATCH 292/312] test: 04-word-at. --- check.sh | 1 + gash/script.scm | 4 ++-- test/04-echo-word-at.sh | 1 + test/04-echo-word-at.stdout | 1 + 4 files changed, 5 insertions(+), 2 deletions(-) create mode 100644 test/04-echo-word-at.sh create mode 100644 test/04-echo-word-at.stdout diff --git a/check.sh b/check.sh index 8ed8675..9a430d2 100755 --- a/check.sh +++ b/check.sh @@ -31,6 +31,7 @@ tests=' 04-echo-var 04-echo-equal +04-echo-word-at 05-assignment 05-assignment-echo diff --git a/gash/script.scm b/gash/script.scm index 8a2e226..d909a30 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -105,8 +105,8 @@ (run ast) 0)) (((? string?) ..1) (exec (append-map glob args))) - (((and (or (? string?)) c) ((and (? string?) a) ...)) - (exec (append-map glob (cons c a)))) + (((and (or (? string?)) c) ... ((and (? string?) a) ...)) + (apply command (append c a))) (_ (exec (append-map glob args))))) (define (glob? pattern) diff --git a/test/04-echo-word-at.sh b/test/04-echo-word-at.sh new file mode 100644 index 0000000..b3ba18e --- /dev/null +++ b/test/04-echo-word-at.sh @@ -0,0 +1 @@ +echo command $@ diff --git a/test/04-echo-word-at.stdout b/test/04-echo-word-at.stdout new file mode 100644 index 0000000..6253d76 --- /dev/null +++ b/test/04-echo-word-at.stdout @@ -0,0 +1 @@ +command -s --long file0 file1 From d4f58ffa198e905b2d93ca1c791d50d7b60e457a Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 2 Dec 2018 09:51:41 +0100 Subject: [PATCH 293/312] test: 04-word-at-word. --- check.sh | 1 + gash/script.scm | 23 +++++++++++++---------- test/04-echo-word-at-word.sh | 1 + test/04-echo-word-at-word.stdout | 1 + 4 files changed, 16 insertions(+), 10 deletions(-) create mode 100644 test/04-echo-word-at-word.sh create mode 100644 test/04-echo-word-at-word.stdout diff --git a/check.sh b/check.sh index 9a430d2..4d0cd40 100755 --- a/check.sh +++ b/check.sh @@ -32,6 +32,7 @@ tests=' 04-echo-var 04-echo-equal 04-echo-word-at +04-echo-word-at-word 05-assignment 05-assignment-echo diff --git a/gash/script.scm b/gash/script.scm index d909a30..6bc44ad 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -80,6 +80,10 @@ (run ast))) (define (command . args) + (define (flatten o) + (match o + ((h t ...) (append (flatten h) (append-map flatten t))) + (_ (list o)))) (define (exec command) (cond ((procedure? command) command) ((assoc-ref %functions (car command)) @@ -98,16 +102,15 @@ (else (lambda () #t)))) (when (> %debug-level 1) (format (current-error-port) "command: ~s\n" args)) - (match args - (((or "." "source") file-name) - (let* ((string (with-input-from-file file-name read-string)) - (ast (parse-string string))) - (run ast) - 0)) - (((? string?) ..1) (exec (append-map glob args))) - (((and (or (? string?)) c) ... ((and (? string?) a) ...)) - (apply command (append c a))) - (_ (exec (append-map glob args))))) + (let ((args (flatten args))) + (match args + (((or "." "source") file-name) + (let* ((string (with-input-from-file file-name read-string)) + (ast (parse-string string))) + (run ast) + 0)) + (((? string?) ..1) (exec (append-map glob args))) + (_ (exec (append-map glob args)))))) (define (glob? pattern) (and (string? pattern) (string-match "\\?|\\*" pattern))) diff --git a/test/04-echo-word-at-word.sh b/test/04-echo-word-at-word.sh new file mode 100644 index 0000000..9f90b61 --- /dev/null +++ b/test/04-echo-word-at-word.sh @@ -0,0 +1 @@ +echo command $@ plus diff --git a/test/04-echo-word-at-word.stdout b/test/04-echo-word-at-word.stdout new file mode 100644 index 0000000..802f789 --- /dev/null +++ b/test/04-echo-word-at-word.stdout @@ -0,0 +1 @@ +command -s --long file0 file1 plus From f7617fce476f8b9c4e2223246bc073da31e2981b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 3 Dec 2018 20:59:10 +0100 Subject: [PATCH 294/312] builtins: test: Fix a = b. --- check.sh | 1 + gash/builtins.scm | 7 ++++--- test/100-test.sh | 3 +++ 3 files changed, 8 insertions(+), 3 deletions(-) create mode 100644 test/100-test.sh diff --git a/check.sh b/check.sh index 4d0cd40..275f9e0 100755 --- a/check.sh +++ b/check.sh @@ -124,6 +124,7 @@ tests=' 100-cd 100-cd-foo +100-test 100-test-file 100-bracket-file diff --git a/gash/builtins.scm b/gash/builtins.scm index 84235cc..48eabb4 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -298,10 +298,11 @@ Options: ")) (version? (format #t "test (GASH) ~a\n" %version)) ((null? files) #f) - ((or (option-ref options 'n #f) - no-options?) + ((or (option-ref options 'string-not-null #f) + (and no-options? + (= (length files) 1))) (not (string-null? file))) - ((option-ref options 'z #f) + ((option-ref options 'string-null #f) (string-null? file)) ((and (= (length files) 3) (member (cadr files) '("=" "=="))) diff --git a/test/100-test.sh b/test/100-test.sh new file mode 100644 index 0000000..6e513ec --- /dev/null +++ b/test/100-test.sh @@ -0,0 +1,3 @@ +if test a = b; then + exit 1; +fi From 53fe775de9dc6317d6a680cda309881b7edab738 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 4 Dec 2018 10:09:17 +0100 Subject: [PATCH 295/312] chmod: Recurse also chmod's directories. --- gash/commands/chmod.scm | 6 +++--- gash/shell-utils.scm | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/gash/commands/chmod.scm b/gash/commands/chmod.scm index 6cb2308..df1ab14 100644 --- a/gash/commands/chmod.scm +++ b/gash/commands/chmod.scm @@ -92,8 +92,8 @@ Each MODE is of the form '[ugoa]*([-+=]([rwxXst]*|[ugo]))+|[-+=][0-7]+'. (m (if xecutable? (cons (make-chmodifier 'o '- '(X)) m) m))) (values m files))) (else (values (parse-chmodifiers (car files)) (cdr files)))) - (let ((files (if (option-ref options 'recursive #f) (append-map find-files files) - files))) - (for-each (cut apply-chmodifiers <> modifiers) files))))))) + (let ((files (if (not (option-ref options 'recursive #f)) files + (append-map (cut find-files <> #:directories? #t) files)))) + (for-each (cut apply-chmodifiers <> modifiers) (reverse files)))))))) (define main chmod) diff --git a/gash/shell-utils.scm b/gash/shell-utils.scm index 288a7c6..4c27624 100644 --- a/gash/shell-utils.scm +++ b/gash/shell-utils.scm @@ -517,7 +517,7 @@ end of a line; by itself it won't match the terminating newline of a line." program o)))))) (define (apply-chmodifiers file modifiers) - (let ((mode (chmodifiers->mode modifiers (warn 'file-mode(stat:mode (lstat file)))))) + (let ((mode (chmodifiers->mode modifiers (stat:mode (lstat file))))) ((@ (guile) chmod) file mode))) (define (chmodifier-numeric-mode o executable?) From 42d52d1a70da4e7ecbdf710e154102c2085713b7 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 4 Dec 2018 07:03:31 +0100 Subject: [PATCH 296/312] tar: Support extracting of read-only archives. --- check.sh | 1 + gash/ustar.scm | 64 +++++++++++++++++++++++------------------ test/100-tar-ro.sh | 3 ++ test/100-tar-ro.stdout | 3 ++ test/data/ro.tar | Bin 0 -> 10240 bytes 5 files changed, 43 insertions(+), 28 deletions(-) create mode 100644 test/100-tar-ro.sh create mode 100644 test/100-tar-ro.stdout create mode 100644 test/data/ro.tar diff --git a/check.sh b/check.sh index 275f9e0..ce67ba8 100755 --- a/check.sh +++ b/check.sh @@ -143,6 +143,7 @@ tests=' 100-tar-Z 100-tar-Z-old 100-tar-Z-pipe +100-tar-ro 100-tr ' diff --git a/gash/ustar.scm b/gash/ustar.scm index b8c7bb5..a590a9d 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -453,17 +453,17 @@ #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity)) files)))))) -(define (ustar-header-file-name header) - (let ((name (ustar-header-name header)) - (prefix (ustar-header-prefix header))) - (if (string-null? prefix) name - (string-append prefix "/" name)))) +(define* (ustar-header-file-name header #:key (strip 0)) + (let* ((name (ustar-header-name header)) + (prefix (ustar-header-prefix header)) + (file-name (if (string-null? prefix) name + (string-append prefix "/" name)))) + (if (zero? strip) file-name + (string-join (list-tail (string-split file-name #\/) strip) "/")))) (define* (read-ustar-file port header #:key (extract? #t) (strip 0)) (let* ((size (ustar-header-size header)) - (file-name (ustar-header-file-name header)) - (file-name (if (zero? strip) file-name - (string-join (list-tail (string-split file-name #\/) strip) "/"))) + (file-name (ustar-header-file-name header #:strip strip)) (dir (dirname file-name)) (extract? (and extract? (not (string-null? file-name)))) (thunk (lambda _ @@ -481,18 +481,18 @@ (when extract? (mkdir-p dir)) (if extract? - (case (ustar-header-type header) - ((regular) - (if (file-exists? file-name) (delete-file file-name)) - (with-output-to-file file-name thunk #:binary #t)) - ((directory) (mkdir-p file-name)) - ((symlink) (symlink (ustar-header-link-name header) file-name ))) - (thunk)) - (when (and extract? - (not (eq? (ustar-header-type header) 'symlink))) - (chmod file-name (ustar-header-mode header)) - (let ((mtime (ustar-header-mtime header))) - (utime file-name mtime mtime))))) + (let ((mtime (ustar-header-mtime header))) + (case (ustar-header-type header) + ((regular) + (if (file-exists? file-name) (delete-file file-name)) + (with-output-to-file file-name thunk #:binary #t) + (utime file-name mtime mtime) + (chmod file-name (ustar-header-mode header))) + ((directory) + (mkdir-p file-name) + (utime file-name mtime mtime)) + ((symlink) (symlink (ustar-header-link-name header) file-name )))) + (thunk)))) (define (ustar-header->stat header) (let* ((stat-size 17) @@ -516,7 +516,8 @@ (for-each (cut write-ustar-file out <> #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:sort-order sort-order #:verbosity verbosity) - files)) + files) + (write-ustar-footer out)) (define* (write-ustar-archive file-name files #:key group mtime numeric-owner? owner sort-order verbosity) (catch #t @@ -531,13 +532,20 @@ (exit 1)))) (define* (read-ustar-port in files #:key (extract? #t) (strip 0) verbosity) - (let loop ((header (read-ustar-header in))) - (when (and header - (not (eof-object? header))) - (unless (zero? verbosity) - (display-header header #:verbose? (> verbosity 1))) - (read-ustar-file in header #:extract? extract? #:strip strip) - (loop (read-ustar-header in))))) + (let ((dirs + (let loop ((header (read-ustar-header in)) (dirs '())) + (if (not (and header (not (eof-object? header)))) dirs + (begin + (unless (zero? verbosity) + (display-header header #:verbose? (> verbosity 1))) + (read-ustar-file in header #:extract? extract? #:strip strip) + (loop (read-ustar-header in) + (if (eq? (ustar-header-type header) 'directory) (cons header dirs) + dirs))))))) + (define (chmod-header header) + (chmod (ustar-header-file-name header #:strip strip) + (ustar-header-mode header))) + (for-each chmod-header dirs))) (define* (read-ustar-archive file-name files #:key (extract? #t) (strip 0) verbosity) (catch #t diff --git a/test/100-tar-ro.sh b/test/100-tar-ro.sh new file mode 100644 index 0000000..dde8b10 --- /dev/null +++ b/test/100-tar-ro.sh @@ -0,0 +1,3 @@ +\tar -xvf test/data/ro.tar +\chmod -R +w foo +\rm -r foo diff --git a/test/100-tar-ro.stdout b/test/100-tar-ro.stdout new file mode 100644 index 0000000..3d84aa0 --- /dev/null +++ b/test/100-tar-ro.stdout @@ -0,0 +1,3 @@ +foo/ +foo/bar/ +foo/bar/baz diff --git a/test/data/ro.tar b/test/data/ro.tar new file mode 100644 index 0000000000000000000000000000000000000000..82ff88a829899354efa04988afa26ebed280b00d GIT binary patch literal 10240 zcmeIxO$x#=5QgD7N^W2#Kh1ekXcr1CRNZ)blY-Dqv73nEJDU`SCgJ%q<2;|FaoJKa zMk$M?Xt!%^)e`l=YH+G9h*b?fiHVKxwQhgE-tuCMobxmdmtptFcm3TTzq>J({QJB# zeFHV%5A3~YyL-W7p-z6``HoMVg<3FGOjRc Date: Tue, 4 Dec 2018 19:17:10 +0100 Subject: [PATCH 297/312] set: Ignore set -o, set +o. --- gash/builtins.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/gash/builtins.scm b/gash/builtins.scm index 48eabb4..0083da8 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -112,6 +112,8 @@ (("+u") (set-shell-opt! "nounset" #f)) (("-x") (set-shell-opt! "xtrace" #t)) (("+x") (set-shell-opt! "xtrace" #f)) + (("-o" option) (format (current-error-port) "warning: set: not supported: ~a\n" args)) + (("+o" option) (format (current-error-port) "warning: set: not supported: ~a\n" args)) (((and (? string?) arg)) (let* ((lst (string->string-list arg)) (set (car lst))) (when (not (member set '("-" "+"))) From 179ae8cddd8c087b640e429109db1ca76050d8de Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 4 Dec 2018 19:17:25 +0100 Subject: [PATCH 298/312] grammar: Support \[ builtin. --- gash/grammar.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gash/grammar.scm b/gash/grammar.scm index 5473fff..395a43d 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -115,7 +115,7 @@ until-clause <-- until-keyword compound do-group - test <- '[' sp+ test-args sp+ ']'# + test <- ('[' / '\\[') sp+ test-args sp+ ']'# test-args <-- (sp* word)+ literal <- !reserved (escaped / !allowed .)+ @@ -294,7 +294,7 @@ (('pipeline ('command ('word "shift"))) '(shift)) - (('command ('word "[" ('test-args test-args ...) "]")) + (('command ('word (or "[" "\\[") ('test-args test-args ...) "]")) `(command (word "[") ,@(map transform test-args) (word "]"))) ((h t ...) (map transform o)) From 5b7f85aa3d15523edd05a07ed2b16b6f69690d53 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 4 Dec 2018 20:15:53 +0100 Subject: [PATCH 299/312] Fix [, use \[ in tests. --- gash/builtins.scm | 22 +++++++++++----------- gash/grammar.scm | 4 ++-- test/10-if-bracket-false.sh | 2 +- test/10-if-bracket.sh | 2 +- test/10-if-word-variable.sh | 2 +- test/100-bracket-file.sh | 2 +- 6 files changed, 17 insertions(+), 17 deletions(-) diff --git a/gash/builtins.scm b/gash/builtins.scm index 0083da8..a5d125c 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -317,7 +317,8 @@ Options: (expression (pipeline (command expression))))) ((not (= (length files) 1)) - (format (current-error-port) "test: too many files: ~a\n" files) + (format (current-error-port) "test: too many files: ~s\n" files) + (format (current-error-port) "test: command: ~s\n" args) 1) ((option-ref options 'is-file #f) (regular-file? file)) @@ -343,16 +344,15 @@ Options: (case-lambda (() #f) (args - (lambda _ - (cond ((and (pair? args) (equal? (car args) "--help")) - (test-command "--help")) - ((and (pair? args) (equal? (car args) "--version")) - (test-command "--version")) - (else - (if (not (equal? (last args) "]")) (begin - (format (current-error-port) "gash: [: missing `]'\n") - #f) - (apply test-command (drop-right args 1))))))))) + (cond ((and (pair? args) (equal? (car args) "--help")) + (test-command "--help")) + ((and (pair? args) (equal? (car args) "--version")) + (test-command "--version")) + (else + (if (not (equal? (last args) "]")) (begin + (format (current-error-port) "gash: [: missing `]'\n") + #f) + (apply test-command (drop-right args 1)))))))) (define (term->string o) (match o diff --git a/gash/grammar.scm b/gash/grammar.scm index 395a43d..eb96872 100644 --- a/gash/grammar.scm +++ b/gash/grammar.scm @@ -294,8 +294,8 @@ (('pipeline ('command ('word "shift"))) '(shift)) - (('command ('word (or "[" "\\[") ('test-args test-args ...) "]")) - `(command (word "[") ,@(map transform test-args) (word "]"))) + (('command ('word (and (or "[" "\\[") bracket) ('test-args test-args ...) "]")) + `(command (word ,bracket) ,@(map transform test-args) (word "]"))) ((h t ...) (map transform o)) (_ o))) diff --git a/test/10-if-bracket-false.sh b/test/10-if-bracket-false.sh index acac19b..1833999 100644 --- a/test/10-if-bracket-false.sh +++ b/test/10-if-bracket-false.sh @@ -1,4 +1,4 @@ -if [ 0 = 1 ]; then +if \[ 0 = 1 ]; then exit 1 fi exit 0 diff --git a/test/10-if-bracket.sh b/test/10-if-bracket.sh index 94b7579..e16309c 100644 --- a/test/10-if-bracket.sh +++ b/test/10-if-bracket.sh @@ -1,4 +1,4 @@ -if [ 1 = 1 ]; then +if \[ 1 = 1 ]; then exit 0 fi exit 1 diff --git a/test/10-if-word-variable.sh b/test/10-if-word-variable.sh index 5902433..cc347dc 100644 --- a/test/10-if-word-variable.sh +++ b/test/10-if-word-variable.sh @@ -1,4 +1,4 @@ -if [ x"$y" = x ]; then +if \[ x"$y" = x ]; then exit 0 fi exit 1 diff --git a/test/100-bracket-file.sh b/test/100-bracket-file.sh index e563697..556197d 100644 --- a/test/100-bracket-file.sh +++ b/test/100-bracket-file.sh @@ -1,4 +1,4 @@ -if [ -f foo-bar ]; then +if \[ -f foo-bar ]; then exit 1 fi From e77273610dc59f92aa853b8939c407146119ec4d Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 2 Dec 2018 07:40:48 +0100 Subject: [PATCH 300/312] guix: Update. --- guix.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/guix.scm b/guix.scm index ea3178f..1701913 100644 --- a/guix.scm +++ b/guix.scm @@ -81,7 +81,7 @@ (define-public guile-gash (let ((version "0.1") - (commit "0a09ab114af631f9763459203014ee5208c9058e") + (commit "5b7f85aa3d15523edd05a07ed2b16b6f69690d53") (revision "0") (builtins '( "basename" @@ -101,6 +101,7 @@ "sed" "tar" "touch" + "tr" "wc" "which" )) @@ -115,7 +116,7 @@ "/gash-" commit ".tar.gz")) (sha256 (base32 - "0986yd6y8jnsbwn5mx6y3ihc0x6mm79qq41ny6c6m1h402n6rw0n")))) + "05nq0knklgk2iczsqmnhnh1365iv6gs3cxam38qf7dmdlglbf0sa")))) (build-system guile-build-system) (arguments `(#:phases From 1d6a0cff998b433f2c47fd034571f443be823d09 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 8 Dec 2018 07:55:55 +0100 Subject: [PATCH 301/312] test: 42-sh-export: New failing test. --- check.sh | 1 + test/41-dot.stdout | 3 ++- test/42-sh-export.sh | 3 +++ test/42-sh-export.stdout | 2 ++ test/42-sh.stdout | 3 ++- test/data/script.sh | 3 ++- 6 files changed, 12 insertions(+), 3 deletions(-) create mode 100644 test/42-sh-export.sh create mode 100644 test/42-sh-export.stdout diff --git a/check.sh b/check.sh index ce67ba8..90ce17f 100755 --- a/check.sh +++ b/check.sh @@ -96,6 +96,7 @@ tests=' 41-dot 42-sh +42-sh-export 50-iohere 50-iohere-builtin diff --git a/test/41-dot.stdout b/test/41-dot.stdout index a486f1a..60839a9 100644 --- a/test/41-dot.stdout +++ b/test/41-dot.stdout @@ -1,2 +1,3 @@ -bar +foo:bar +bar: bar diff --git a/test/42-sh-export.sh b/test/42-sh-export.sh new file mode 100644 index 0000000..fe5449b --- /dev/null +++ b/test/42-sh-export.sh @@ -0,0 +1,3 @@ +bar=baz +export baz +sh test/data/script.sh diff --git a/test/42-sh-export.stdout b/test/42-sh-export.stdout new file mode 100644 index 0000000..1d269f3 --- /dev/null +++ b/test/42-sh-export.stdout @@ -0,0 +1,2 @@ +foo:bar +bar: diff --git a/test/42-sh.stdout b/test/42-sh.stdout index 9972d7e..3b93b9c 100644 --- a/test/42-sh.stdout +++ b/test/42-sh.stdout @@ -1,2 +1,3 @@ -bar +foo:bar +bar: diff --git a/test/data/script.sh b/test/data/script.sh index 4b4cd91..ffcb69c 100644 --- a/test/data/script.sh +++ b/test/data/script.sh @@ -1,2 +1,3 @@ foo=bar -echo $foo +echo foo:$foo +echo bar:$bar From f8a4f8aeae507277181bbf73427e9fe0b817564a Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 8 Dec 2018 08:36:36 +0100 Subject: [PATCH 302/312] doc: Some updates. --- HACKING | 23 +++++++++++++++++++++++ INSTALL | 1 - doc/gash.texi | 3 ++- 3 files changed, 25 insertions(+), 2 deletions(-) create mode 100644 HACKING diff --git a/HACKING b/HACKING new file mode 100644 index 0000000..abed6a0 --- /dev/null +++ b/HACKING @@ -0,0 +1,23 @@ +Working up to a 0.1 release. + +TODO: + * Fix word/delim/substitute + * Implement export + * Pass all tests + * Add missing tests, repeat :-) + +Try + + make check-bash + make check-gash + +or + + bash -e test/42-sh-export.sh + ./pre-inst-env gash -e test/42-sh-export.sh + +To use Geesh, assuming you have built it in ../geesh, do something like + + GUILE_LOAD_PATH=../geesh:$GUILE_LOAD_PATH + GUILE_LOAD_COMPILED_PATH=../geesh:$GUILE_LOAD_COMPILED_PATH + ./pre-inst-env gash --geesh -dd -p -c 'cat < README > bla' diff --git a/INSTALL b/INSTALL index 7835cdc..caa5bac 100644 --- a/INSTALL +++ b/INSTALL @@ -22,7 +22,6 @@ Building and Installing Gash ** Check it make check - ** Install it make install diff --git a/doc/gash.texi b/doc/gash.texi index d818591..8b21b22 100644 --- a/doc/gash.texi +++ b/doc/gash.texi @@ -11,6 +11,7 @@ @copying Copyright @copyright{} 2018 Rutger EW van Beusekom@* +Copyright @copyright{} 2018 Jan (janneke) Nieuwenhuizen@* Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -29,7 +30,7 @@ Documentation License''. @titlepage @title Gash Reference Manual @subtitle A POSIX-compliant sh replacement in Guile Scheme. -@author Jan (janneke) Nieuwenhuizen +@author The Gash developers @page @vskip 0pt plus 1filll From 8757ab67fb03308e0a6d69f6f1da7b57b2e84965 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 9 Dec 2018 04:13:27 +0100 Subject: [PATCH 303/312] basename: fix /, add autoconf basename, dirname tests. --- check.sh | 5 +++++ gash/commands/basename.scm | 5 +++-- test/100-basename-autoconf.sh | 6 ++++++ test/100-basename-autoconf.stdout | 1 + test/100-basename-root.sh | 2 ++ test/100-basename-root.stdout | 2 ++ test/100-dirname-autoconf.sh | 6 ++++++ test/100-dirname-autoconf.stdout | 1 + test/100-dirname-root.sh | 2 ++ test/100-dirname-root.stdout | 2 ++ 10 files changed, 30 insertions(+), 2 deletions(-) create mode 100644 test/100-basename-autoconf.sh create mode 100644 test/100-basename-autoconf.stdout create mode 100644 test/100-basename-root.sh create mode 100644 test/100-basename-root.stdout create mode 100644 test/100-dirname-autoconf.sh create mode 100644 test/100-dirname-autoconf.stdout create mode 100644 test/100-dirname-root.sh create mode 100644 test/100-dirname-root.stdout diff --git a/check.sh b/check.sh index 90ce17f..2055373 100755 --- a/check.sh +++ b/check.sh @@ -129,6 +129,11 @@ tests=' 100-test-file 100-bracket-file +100-basename-root +100-dirname-root +100-basename-autoconf +100-dirname-autoconf + 100-sed 100-sed-once 100-sed-global diff --git a/gash/commands/basename.scm b/gash/commands/basename.scm index 441f5b4..9c4a4fc 100644 --- a/gash/commands/basename.scm +++ b/gash/commands/basename.scm @@ -68,8 +68,9 @@ Options: (if (and (> (string-length file) 1) (string-suffix? "/" file)) (string-drop-right file 1) file))) - (if suffix (display ((@ (guile) basename) file suffix)) - (display ((@ (guile) basename) file)))) + (cond ((string=? file "/") (display "/")) + (suffix (display ((@ (guile) basename) file suffix))) + (else (display ((@ (guile) basename) file))))) (if zero? (display #\nul) (newline))) files)))))) diff --git a/test/100-basename-autoconf.sh b/test/100-basename-autoconf.sh new file mode 100644 index 0000000..74a383a --- /dev/null +++ b/test/100-basename-autoconf.sh @@ -0,0 +1,6 @@ +if (\basename -- /) >/dev/null 2>&1 && \test "X`\basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi +echo as_basename:$as_basename diff --git a/test/100-basename-autoconf.stdout b/test/100-basename-autoconf.stdout new file mode 100644 index 0000000..d6dbd76 --- /dev/null +++ b/test/100-basename-autoconf.stdout @@ -0,0 +1 @@ +as_basename:basename diff --git a/test/100-basename-root.sh b/test/100-basename-root.sh new file mode 100644 index 0000000..72182c6 --- /dev/null +++ b/test/100-basename-root.sh @@ -0,0 +1,2 @@ +\basename /root +\basename / diff --git a/test/100-basename-root.stdout b/test/100-basename-root.stdout new file mode 100644 index 0000000..7c86684 --- /dev/null +++ b/test/100-basename-root.stdout @@ -0,0 +1,2 @@ +root +/ diff --git a/test/100-dirname-autoconf.sh b/test/100-dirname-autoconf.sh new file mode 100644 index 0000000..c2597c0 --- /dev/null +++ b/test/100-dirname-autoconf.sh @@ -0,0 +1,6 @@ +if (as_dir=`\dirname -- /` && \test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi +echo as_dirname:$as_dirname diff --git a/test/100-dirname-autoconf.stdout b/test/100-dirname-autoconf.stdout new file mode 100644 index 0000000..547ed0e --- /dev/null +++ b/test/100-dirname-autoconf.stdout @@ -0,0 +1 @@ +as_dirname:dirname diff --git a/test/100-dirname-root.sh b/test/100-dirname-root.sh new file mode 100644 index 0000000..11a7935 --- /dev/null +++ b/test/100-dirname-root.sh @@ -0,0 +1,2 @@ +\dirname /root +\dirname / diff --git a/test/100-dirname-root.stdout b/test/100-dirname-root.stdout new file mode 100644 index 0000000..9ba960f --- /dev/null +++ b/test/100-dirname-root.stdout @@ -0,0 +1,2 @@ +/ +/ From 0568f73a21ec24600ac5933eb3e54b20b358f25b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 9 Dec 2018 04:28:27 +0100 Subject: [PATCH 304/312] test: failing 100-sed-autoconf-dirname test. --- check.sh | 1 + test/100-sed-autoconf-dirname.sh | 15 +++++++++++++++ test/100-sed-autoconf-dirname.stdout | 1 + 3 files changed, 17 insertions(+) create mode 100644 test/100-sed-autoconf-dirname.sh create mode 100644 test/100-sed-autoconf-dirname.stdout diff --git a/check.sh b/check.sh index 2055373..f3ef06c 100755 --- a/check.sh +++ b/check.sh @@ -144,6 +144,7 @@ tests=' 100-sed-undo 100-sed-file 100-sed-fooRbar +100-sed-autoconf-dirname 100-tar 100-tar-Z diff --git a/test/100-sed-autoconf-dirname.sh b/test/100-sed-autoconf-dirname.sh new file mode 100644 index 0000000..fd7f5b3 --- /dev/null +++ b/test/100-sed-autoconf-dirname.sh @@ -0,0 +1,15 @@ +dirname='/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q' + +echo 'X/foo/bar' | \sed "$dirname" diff --git a/test/100-sed-autoconf-dirname.stdout b/test/100-sed-autoconf-dirname.stdout new file mode 100644 index 0000000..5716ca5 --- /dev/null +++ b/test/100-sed-autoconf-dirname.stdout @@ -0,0 +1 @@ +bar From 194c098ab78f10153028abe11a89fcc2e8f2e7da Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Sun, 9 Dec 2018 13:30:54 -0500 Subject: [PATCH 305/312] sed: Fully parse commands before processing them. --- build-aux/build-guile.sh | 2 + gash/commands/sed.scm | 84 ++++++--- gash/commands/sed/reader.scm | 322 +++++++++++++++++++++++++++++++++++ 3 files changed, 383 insertions(+), 25 deletions(-) create mode 100644 gash/commands/sed/reader.scm diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 91e1a0c..6817a3c 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -77,6 +77,8 @@ ${srcdest}gash/commands/tr.scm ${srcdest}gash/commands/wc.scm ${srcdest}gash/commands/which.scm +${srcdest}gash/commands/sed/reader.scm + " SCRIPTS=" diff --git a/gash/commands/sed.scm b/gash/commands/sed.scm index 1d55117..fc78574 100644 --- a/gash/commands/sed.scm +++ b/gash/commands/sed.scm @@ -1,5 +1,6 @@ ;;; Gash --- Guile As SHell ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2018 Timothy Sample ;;; ;;; This file is part of Gash. ;;; @@ -25,7 +26,9 @@ #:use-module (ice-9 match) #:use-module (ice-9 receive) #:use-module (ice-9 regex) + #:use-module (srfi srfi-26) + #:use-module (gash commands sed reader) #:use-module (gash config) #:use-module (gash guix-utils) #:use-module (gash shell-utils) @@ -35,7 +38,7 @@ sed )) -(define (replace->lambda string modifiers) +(define (replace->lambda string global?) (define (replace->string m s) (list->string (let loop ((lst (string->list string))) @@ -73,9 +76,51 @@ (let* ((refs (- (vector-length m) 2)) (replace (replace->string m string)) (replace (cons* replace (substring l o (match:start m)) r))) - (if (memq #\g modifiers) (loop rest (match:end m) replace) + (if global? (loop rest (match:end m) replace) (loop '() (match:end m) replace)))))))) +(define (replace-escapes str) + (let* ((str (string-replace-string str "\\n" "\n")) + (str (string-replace-string str "\\r" "\r")) + (str (string-replace-string str "\\t" "\t"))) + str)) + +(define extended? (make-parameter #f)) + +(define (substitute str pattern replacement flags) + (let* ((global? (memq 'g flags)) + (flags (cons (if (extended?) regexp/extended regexp/basic) + (if (memq 'i flags) `(,regexp/icase) '()))) + (regexp (apply make-regexp (replace-escapes pattern) flags)) + (proc (replace->lambda (replace-escapes replacement) global?))) + (match (list-matches regexp str) + ((and m+ (_ _ ...)) (proc str m+)) + (_ str)))) + +(define (execute-function function str) + (match function + (('s pattern replacement flags) + (substitute str pattern replacement flags)) + (_ (error "SED: unsupported function" function)))) + +(define (execute-commands commands str) + (match commands + (() str) + ((('always function) . rest) + (execute-commands rest (execute-function function str))) + ((cmd . rest) (error "SED: could not process command" cmd)))) + +(define* (edit-stream commands #:optional + (in (current-input-port)) + (out (current-output-port))) + (let loop ((pattern-space (read-line in))) + (unless (eof-object? pattern-space) + (let ((result (execute-commands commands pattern-space))) + (display result out) + (newline out) + (loop (read-line in)))) + #t)) + (define (sed . args) (let* ((option-spec '((expression (single-char #\e) (value #t)) @@ -87,12 +132,13 @@ (version (single-char #\V)))) (options (getopt-long args option-spec)) (files (option-ref options '() '())) - (extended? (or (option-ref options 'extended #f) - (option-ref options 'posix-extended #f))) (help? (option-ref options 'help #f)) (in-place? (option-ref options 'in-place #f)) (usage? (and (not help?) (or (and (null? files) (isatty? (current-input-port)))))) (version? (option-ref options 'version #f))) + (when (or (option-ref options 'extended #f) + (option-ref options 'posix-extended #f)) + (extended? #t)) (cond (version? (format #t "sed (GASH) ~a\n" %version) (exit 0)) ((or help? usage?) (format (if usage? (current-error-port) #t) "\ @@ -111,33 +157,21 @@ Usage: sed [OPTION]... [SCRIPT] [FILE]... (receive (scripts files) (if (pair? (append script-files scripts)) (values scripts files) (values (list-head files 1) (cdr files))) - (define (script->command o) - (cond ((string-prefix? "s" o) - (let* ((command (substring o 1)) - (string (substring command 1)) - (string (string-replace-string string "\\n" "\n")) - (string (string-replace-string string "\\r" "\r")) - (string (string-replace-string string "\\t" "\t")) - (separator (string-ref command 0))) - (receive (search replace modifier-string) - (apply values (string-split string separator)) - (let* ((modifiers (string->list modifier-string)) - (flags (if extended? (list regexp/extended) (list regexp/basic))) - (flags (if (memq #\i modifiers) (cons regexp/icase flags) - flags))) - `((,search . ,flags) . ,(replace->lambda replace modifiers)))))) - (else (error (format #f "SED: command not supported: ~s\n" o))))) (when (pair? script-files) (error "SED: script files not supported")) - (let ((commands (map script->command scripts))) + (let* ((script (string-join scripts "\n")) + (commands + (call-with-input-string script + (cut read-sed-all <> #:extended? (extended?))))) (cond ((and in-place? (pair? files)) - (for-each (lambda (file) (substitute* file commands)) files)) + (with-atomic-file-replacement + (cut edit-stream commands <> <>))) ((pair? files) (for-each (lambda (file) - (with-input-from-file file - (lambda _ (substitute-port commands)))) + (call-with-input-file file + (cut edit-stream commands <>))) files)) - (else (substitute-port commands)))))))))) + (else (edit-stream commands)))))))))) (use-modules (ice-9 rdelim)) (define main sed) diff --git a/gash/commands/sed/reader.scm b/gash/commands/sed/reader.scm new file mode 100644 index 0000000..8e9387d --- /dev/null +++ b/gash/commands/sed/reader.scm @@ -0,0 +1,322 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2018 Timothy Sample +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +(define-module (gash commands sed reader) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (read-sed + read-sed-all)) + +;;; Commentary: +;;; +;;; This module provides a reader for the `sed' stream editing +;;; language. +;;; +;;; Code: + +(define (next-char port) + "Discard one character from PORT, and return the next character to +be read." + (get-char port) + (lookahead-char port)) + +(define (get-char-while cs port) + "Read text from PORT until a character is found that does not belong +to the character set CS." + (let loop ((chr (lookahead-char port)) (acc '())) + (if (or (eof-object? chr) + (not (char-set-contains? cs chr))) + (reverse-list->string acc) + (loop (next-char port) (cons chr acc))))) + +(define (read-number port) + "Read a nonnegative integer from PORT." + (let* ((str (get-char-while char-set:digit port)) + (n (string->number str))) + (unless n + (error "Expected a number")) + n)) + +(define (read-bracket-expression port) + "Read a regular expression bracket expression from PORT, +assuming that it is positioned just after the initial open +bracket (`['). Return as a string the complete bracket expression, +including both brackets. + +This procedure takes into account all the ways that a close +bracket (`]') may occur in a bracket expression without terminating +it, such as named character classes and backslash escapes." + + (define (read-until-pair chr1 chr2 port) + (let loop ((chunk (read-delimited chr1 port 'concat)) (acc '())) + (unless (and (not (string-null? chunk)) + (char=? (string-ref chunk (1- (string-length chunk))) + chr1)) + (error "Unterminated bracket expression")) + (if (char=? (lookahead-char port) chr2) + (string->list (string-concatenate (reverse! acc))) + (loop (read-delimited chr1 port 'concat) (cons chunk acc))))) + + (define (read-rest) + (let loop ((chr (get-char port)) (acc '())) + (match chr + ((? eof-object?) (error "Unterminated bracket expression")) + (#\] (reverse-list->string (cons #\] acc))) + (#\[ (match (get-char port) + ((? eof-object?) (error "Unterminated bracket expression")) + ((and cc (or #\= #\. #\:)) + (let ((class (read-until-pair cc #\] port))) + (loop (get-char port) (append-reverse class acc)))) + (chr (loop (get-char port) (cons* chr #\[ acc))))) + (#\\ (match (get-char port) + ((? eof-object?) (error "Unterminated bracket expression")) + (chr (loop (get-char port) (cons* chr #\\ acc))))) + (chr (loop (get-char port) (cons chr acc)))))) + + (match (lookahead-char port) + (#\^ (match (next-char port) + (#\] (get-char port) (string-append "[^]" (read-rest))) + (_ (string-append "[^" (read-rest))))) + (#\] (get-char port) (string-append "[]" (read-rest))) + (_ (string-append "[" (read-rest))))) + +(define %extended? (make-parameter #f)) + +(define (read-re-until delim port) + "Read text from PORT as a regular expression until encountering the +delimiting character DELIM. Return the text of the regular expression +with the trailing delimiter discarded. + +This procedure takes into account the ways that the delimiter could +appear in the regular expression without ending it, such as in a +bracket expression or capture group. It order to determine what +constitutes a capture group, it uses the `%extended?' parameter." + (let loop ((chr (lookahead-char port)) (depth 0) (acc '())) + (cond + ((eof-object? chr) + (error "Unterminated regular expression")) + ((char=? chr #\[) + (get-char port) + (let* ((be (read-bracket-expression port)) + (be-chars (string->list be))) + (loop (lookahead-char port) depth (append-reverse! be-chars acc)))) + ((and (%extended?) (char=? chr #\()) + (loop (next-char port) (1+ depth) (cons #\( acc))) + ((and (%extended?) (char=? chr #\))) + (loop (next-char port) (1- depth) (cons #\) acc))) + ((char=? chr #\\) + (if (%extended?) + (match (next-char port) + ((? eof-object?) (error "Unterminated regular expression")) + (nchr (loop (next-char port) depth (cons* nchr chr acc)))) + (match (next-char port) + ((? eof-object?) (error "Unterminated regular expression")) + (#\( (loop (next-char port) (1+ depth) (cons* #\( chr acc))) + (#\) (loop (next-char port) (1- depth) (cons* #\) chr acc))) + (nchr (loop (next-char port) depth (cons* nchr chr acc)))))) + ((and (= depth 0) + (char=? chr delim)) + (get-char port) + (reverse-list->string acc)) + (else (loop (next-char port) depth (cons chr acc)))))) + +(define (read-string-until delim port) + "Read text from PORT until encountering the character DELIM, +taking into account escaping with backslashes (`\\')." + (let loop ((chr (lookahead-char port)) (acc '())) + (cond + ((eof-object? chr) (error "Unterminated string")) + ((char=? chr #\\) + (let ((next-chr (next-char port))) + (if (eof-object? next-chr) + (error "Unterminated string") + (loop (next-char port) (cons* next-chr chr acc))))) + ((and (char=? chr delim)) + (get-char port) + (reverse-list->string acc)) + (else (loop (next-char port) (cons chr acc)))))) + +(define (read-re port) + "Read a delimited regular expression from PORT." + (let ((delim (get-char port))) + (if (eof-object? delim) + (error "Expected regular expression") + (read-re-until delim port)))) + +(define (read-re+string port) + "Read a delimited regular expression and a replacement string from +PORT." + (let ((delim (get-char port))) + (if (eof-object? delim) + (error "Expected regular expression and replacement") + (let* ((re (read-re-until delim port)) + (str (read-string-until delim port))) + `(,re . ,str))))) + +(define (read-string+string port) + "Read two delimited strings from PORT." + (let ((delim (get-char port))) + (if (eof-object? delim) + (error "Expected characters and their replacements") + (let* ((str1 (read-string-until delim port)) + (str2 (read-string-until delim port))) + `(,str1 . ,str2))))) + +(define (read-text port) + "Read text from PORT until either an unescaped newline or end of +file is encountered." + (get-char-while char-set:whitespace port) + (let loop ((chr (get-char port)) (acc '())) + (match chr + ((or (? eof-object?) + #\newline) + (reverse-list->string acc)) + (#\\ + (let ((next-chr (get-char port))) + (if (eof-object? next-chr) + (error "Unterminated text") + (loop (get-char port) (cons next-chr acc))))) + (_ (loop (get-char port) (cons chr acc)))))) + +(define char-set:label + (string->char-set + (string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "abcdefghijklmnopqrstuvwxyz" + "0123456789._-"))) + +(define label-char? (cut char-set-contains? char-set:label <>)) + +(define (read-label port) + "Read a label from PORT." + (get-char-while char-set:whitespace port) + (get-char-while char-set:label port)) + +(define (read-flags port) + "Read flags (for the `s' command) from PORT." + (let loop ((chr (lookahead-char port)) (acc '())) + (match chr + ((? eof-object?) (reverse! acc)) + (#\g (loop (next-char port) (cons 'g acc))) + (#\i (loop (next-char port) (cons 'i acc))) + (#\p (loop (next-char port) (cons 'p acc))) + ((? (cut char-set-contains? char-set:digit <>)) + (let ((n (read-number port))) + (loop (lookahead-char port) (cons n acc)))) + (#\w + (get-char port) + (let ((filename (read-text port))) + (reverse! (cons `(w ,filename) acc)))) + (_ (reverse! acc))))) + +(define (read-address port) + "Read an address from PORT." + (match (lookahead-char port) + (#\$ '$) + ((? (cut char-set-contains? char-set:digit <>)) (read-number port)) + (_ (read-re port)))) + +(define* (read-function port #:key (depth 0)) + "Read a function and its arguments from PORT." + (get-char-while char-set:whitespace port) + (match (get-char port) + (#\{ `(begin ,@(%read-sed-all port #:depth (1+ depth)))) + (#\a `(a ,(read-text port))) + (#\b `(b ,(read-label port))) + (#\c `(c ,(read-text port))) + (#\d '(d)) + (#\D '(D)) + (#\g '(g)) + (#\G '(G)) + (#\h '(h)) + (#\H '(H)) + (#\i `(i ,(read-text port))) + (#\l '(l)) + (#\n '(n)) + (#\N '(N)) + (#\p '(p)) + (#\P '(P)) + (#\q '(q)) + (#\r `(r ,(read-text port))) + (#\s (match-let (((re . str) (read-re+string port))) + `(s ,re ,str ,(read-flags port)))) + (#\t `(t ,(read-label port))) + (#\w `(w ,(read-text port))) + (#\x '(x)) + (#\y (match-let (((str1 . str2) (read-string+string port))) + `(y ,str1 ,str2))) + (#\: `(: ,(read-label port))) + (#\= `(= ,(1+ (port-line port)))) + (#\# `(comment ,(read-line port))))) + +(define char-set:function + (string->char-set "abcdDgGhHilnNpPqrstwxy:=#")) + +(define function-char? (cut char-set-contains? char-set:function <>)) + +(define (read-addresses port) + "Read zero, one, or two address from PORT, separated by a +comma (`,') and delimited by a function name." + (match (lookahead-char port) + ((? function-char?) '()) + (_ (let ((address1 (read-address port))) + (match (lookahead-char port) + (#\, (let* ((_ (get-char port)) + (address2 (read-address port))) + `(,address1 ,address2))) + (_ `(,address1))))))) + +(define char-set:whitespace+semi (char-set-adjoin char-set:whitespace #\;)) + +(define* (%read-sed port #:key (depth 0)) + "Read a sed command from PORT." + (get-char-while char-set:whitespace+semi port) + (match (lookahead-char port) + ((? eof-object?) (eof-object)) + (#\} + (get-char port) + (if (> depth 0) + (eof-object) + (error "Unmatched close brace"))) + (_ (let* ((addresses (read-addresses port)) + (function (read-function port #:depth depth))) + (match addresses + (() `(always ,function)) + ((address) `(at ,address ,function)) + ((address1 address2) `(in (,address1 . ,address2) ,function))))))) + +(define* (%read-sed-all port #:key (depth 0)) + "Read a sequence of sed commands from PORT." + (let loop ((cmd (%read-sed port #:depth depth)) (acc '())) + (match cmd + ((? eof-object?) (reverse! acc)) + (_ (loop (%read-sed port #:depth depth) (cons cmd acc)))))) + +(define* (read-sed port #:key (extended? #f)) + "Read a sed command from PORT. If EXTENDED? is set, treat regular +expressions as extended rather than basic." + (parameterize ((%extended? extended?)) + (%read-sed port))) + +(define* (read-sed-all port #:key (extended? #f)) + "Read a sequence of sed commands from PORT. If EXTENDED? is set, +treat regular expressions as extended rather than basic." + (parameterize ((%extended? extended?)) + (%read-sed-all port))) From 1302c8bf2832deb891ed9ce8554b8edcb9620a6c Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Sun, 9 Dec 2018 14:03:27 -0500 Subject: [PATCH 306/312] sed: Support single pattern addresses. --- check.sh | 1 + gash/commands/sed.scm | 14 ++++++++++++++ test/100-sed-pattern-address.sh | 5 +++++ test/100-sed-pattern-address.stdout | 3 +++ 4 files changed, 23 insertions(+) create mode 100644 test/100-sed-pattern-address.sh create mode 100644 test/100-sed-pattern-address.stdout diff --git a/check.sh b/check.sh index f3ef06c..a7ebc4f 100755 --- a/check.sh +++ b/check.sh @@ -144,6 +144,7 @@ tests=' 100-sed-undo 100-sed-file 100-sed-fooRbar +100-sed-pattern-address 100-sed-autoconf-dirname 100-tar diff --git a/gash/commands/sed.scm b/gash/commands/sed.scm index fc78574..ab8b980 100644 --- a/gash/commands/sed.scm +++ b/gash/commands/sed.scm @@ -97,6 +97,14 @@ ((and m+ (_ _ ...)) (proc str m+)) (_ str)))) +(define (address->pred address) + (if (string? address) + (let* ((flags `(,(if (extended?) regexp/extended regexp/basic))) + (pattern (replace-escapes address)) + (regexp (apply make-regexp pattern flags))) + (cut regexp-exec regexp <>)) + (error "SED: unsupported address type" address))) + (define (execute-function function str) (match function (('s pattern replacement flags) @@ -108,6 +116,12 @@ (() str) ((('always function) . rest) (execute-commands rest (execute-function function str))) + ((('at address function) . rest) + ;; XXX: This should be "compiled" ahead of time so that it only + ;; runs once intead of once per line. + (if ((address->pred address) str) + (execute-commands rest (execute-function function str)) + (execute-commands rest str))) ((cmd . rest) (error "SED: could not process command" cmd)))) (define* (edit-stream commands #:optional diff --git a/test/100-sed-pattern-address.sh b/test/100-sed-pattern-address.sh new file mode 100644 index 0000000..a58cb9b --- /dev/null +++ b/test/100-sed-pattern-address.sh @@ -0,0 +1,5 @@ +input='bar +baz +bam' + +echo "$input" | \sed '/baz/ s/a/i/' diff --git a/test/100-sed-pattern-address.stdout b/test/100-sed-pattern-address.stdout new file mode 100644 index 0000000..cd6aa0e --- /dev/null +++ b/test/100-sed-pattern-address.stdout @@ -0,0 +1,3 @@ +bar +biz +bam From 5be7ed331daa6ecb39cd8145e78177d051d8655d Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Sun, 9 Dec 2018 14:08:40 -0500 Subject: [PATCH 307/312] sed: Support command lists. --- gash/commands/sed.scm | 2 ++ test/100-sed-command-list.sh | 4 ++++ test/100-sed-command-list.stdout | 2 ++ 3 files changed, 8 insertions(+) create mode 100644 test/100-sed-command-list.sh create mode 100644 test/100-sed-command-list.stdout diff --git a/gash/commands/sed.scm b/gash/commands/sed.scm index ab8b980..6e7a6e1 100644 --- a/gash/commands/sed.scm +++ b/gash/commands/sed.scm @@ -107,6 +107,8 @@ (define (execute-function function str) (match function + (('begin . commands) + (execute-commands commands str)) (('s pattern replacement flags) (substitute str pattern replacement flags)) (_ (error "SED: unsupported function" function)))) diff --git a/test/100-sed-command-list.sh b/test/100-sed-command-list.sh new file mode 100644 index 0000000..b3d918e --- /dev/null +++ b/test/100-sed-command-list.sh @@ -0,0 +1,4 @@ +input='foo +bar' + +echo "$input" | \sed '/foo/ { s/foo/baz/ s/baz/bar/ } s/bar/baz/' diff --git a/test/100-sed-command-list.stdout b/test/100-sed-command-list.stdout new file mode 100644 index 0000000..1f55335 --- /dev/null +++ b/test/100-sed-command-list.stdout @@ -0,0 +1,2 @@ +baz +baz From 489f092131dfffca53de576b2c2af83b42981ec3 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Sun, 9 Dec 2018 14:36:08 -0500 Subject: [PATCH 308/312] sed: Add quit function. --- check.sh | 1 + gash/commands/sed.scm | 16 ++++++++++++---- test/100-sed-quit.sh | 4 ++++ test/100-sed-quit.stdout | 1 + 4 files changed, 18 insertions(+), 4 deletions(-) create mode 100644 test/100-sed-quit.sh create mode 100644 test/100-sed-quit.stdout diff --git a/check.sh b/check.sh index a7ebc4f..68fb3e3 100755 --- a/check.sh +++ b/check.sh @@ -145,6 +145,7 @@ tests=' 100-sed-file 100-sed-fooRbar 100-sed-pattern-address +100-sed-quit 100-sed-autoconf-dirname 100-tar diff --git a/gash/commands/sed.scm b/gash/commands/sed.scm index 6e7a6e1..381393d 100644 --- a/gash/commands/sed.scm +++ b/gash/commands/sed.scm @@ -87,6 +87,8 @@ (define extended? (make-parameter #f)) +(define quit-tag (make-prompt-tag)) + (define (substitute str pattern replacement flags) (let* ((global? (memq 'g flags)) (flags (cons (if (extended?) regexp/extended regexp/basic) @@ -109,6 +111,7 @@ (match function (('begin . commands) (execute-commands commands str)) + (('q) (abort-to-prompt quit-tag str)) (('s pattern replacement flags) (substitute str pattern replacement flags)) (_ (error "SED: unsupported function" function)))) @@ -131,10 +134,15 @@ (out (current-output-port))) (let loop ((pattern-space (read-line in))) (unless (eof-object? pattern-space) - (let ((result (execute-commands commands pattern-space))) - (display result out) - (newline out) - (loop (read-line in)))) + (call-with-prompt quit-tag + (lambda () + (let ((result (execute-commands commands pattern-space))) + (display result out) + (newline out) + (loop (read-line in)))) + (lambda (cont result) + (display result out) + (newline out)))) #t)) (define (sed . args) diff --git a/test/100-sed-quit.sh b/test/100-sed-quit.sh new file mode 100644 index 0000000..df41e6d --- /dev/null +++ b/test/100-sed-quit.sh @@ -0,0 +1,4 @@ +input='foo +bar' + +echo "$input" | \sed 's/foo/baz/ ; q ; s/baz/foo/' diff --git a/test/100-sed-quit.stdout b/test/100-sed-quit.stdout new file mode 100644 index 0000000..7601807 --- /dev/null +++ b/test/100-sed-quit.stdout @@ -0,0 +1 @@ +baz From 7aa7a883e0116f79818b5f26403cfa26d0f89ec3 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Sun, 9 Dec 2018 14:57:12 -0500 Subject: [PATCH 309/312] sed: Add basic support for script files. --- gash/commands/sed.scm | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/gash/commands/sed.scm b/gash/commands/sed.scm index 381393d..8f8d456 100644 --- a/gash/commands/sed.scm +++ b/gash/commands/sed.scm @@ -26,6 +26,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 receive) #:use-module (ice-9 regex) + #:use-module (rnrs io ports) #:use-module (srfi srfi-26) #:use-module (gash commands sed reader) @@ -179,10 +180,17 @@ Usage: sed [OPTION]... [SCRIPT] [FILE]... (let* ((script-files (multi-opt options 'file)) (scripts (multi-opt options 'expression))) (receive (scripts files) - (if (pair? (append script-files scripts)) (values scripts files) - (values (list-head files 1) (cdr files))) - (when (pair? script-files) - (error "SED: script files not supported")) + (cond + ((and (pair? script-files) (pair? scripts)) + ;; XXX: Until we respect the order in which scripts + ;; are specified, we cannot do this properly. + (error "SED: cannot mix argument and file scripts")) + ((pair? script-files) + (values (map (cut call-with-input-file <> get-string-all) + script-files) + files)) + ((pair? scripts) (values scripts files)) + (else (values (list-head files 1) (cdr files)))) (let* ((script (string-join scripts "\n")) (commands (call-with-input-string script From 8c5a9ea96fad122ad73657fb6e5081caec8bbf1f Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Sun, 9 Dec 2018 15:51:27 -0500 Subject: [PATCH 310/312] test: Rename sed dirname test to basename. --- check.sh | 2 +- ...0-sed-autoconf-dirname.sh => 100-sed-autoconf-basename.sh} | 4 ++-- ...toconf-dirname.stdout => 100-sed-autoconf-basename.stdout} | 0 3 files changed, 3 insertions(+), 3 deletions(-) rename test/{100-sed-autoconf-dirname.sh => 100-sed-autoconf-basename.sh} (62%) rename test/{100-sed-autoconf-dirname.stdout => 100-sed-autoconf-basename.stdout} (100%) diff --git a/check.sh b/check.sh index 68fb3e3..3c64bf8 100755 --- a/check.sh +++ b/check.sh @@ -146,7 +146,7 @@ tests=' 100-sed-fooRbar 100-sed-pattern-address 100-sed-quit -100-sed-autoconf-dirname +100-sed-autoconf-basename 100-tar 100-tar-Z diff --git a/test/100-sed-autoconf-dirname.sh b/test/100-sed-autoconf-basename.sh similarity index 62% rename from test/100-sed-autoconf-dirname.sh rename to test/100-sed-autoconf-basename.sh index fd7f5b3..ddd8ea5 100644 --- a/test/100-sed-autoconf-dirname.sh +++ b/test/100-sed-autoconf-basename.sh @@ -1,4 +1,4 @@ -dirname='/^.*\/\([^/][^/]*\)\/*$/{ +basename='/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } @@ -12,4 +12,4 @@ dirname='/^.*\/\([^/][^/]*\)\/*$/{ } s/.*/./; q' -echo 'X/foo/bar' | \sed "$dirname" +echo 'X/foo/bar' | \sed "$basename" diff --git a/test/100-sed-autoconf-dirname.stdout b/test/100-sed-autoconf-basename.stdout similarity index 100% rename from test/100-sed-autoconf-dirname.stdout rename to test/100-sed-autoconf-basename.stdout From cb8b2758e06ee13e12fb767fc8a8aab6f4ed75f8 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Sun, 9 Dec 2018 15:53:01 -0500 Subject: [PATCH 311/312] test: Use script file for sed basename test. As of this commit, Gash does not process the quotes around the script properly, and ends up calling sed with no arguments. --- test/100-sed-autoconf-basename.sh | 16 +--------------- test/data/basename.sed | 13 +++++++++++++ 2 files changed, 14 insertions(+), 15 deletions(-) create mode 100644 test/data/basename.sed diff --git a/test/100-sed-autoconf-basename.sh b/test/100-sed-autoconf-basename.sh index ddd8ea5..a69a94b 100644 --- a/test/100-sed-autoconf-basename.sh +++ b/test/100-sed-autoconf-basename.sh @@ -1,15 +1 @@ -basename='/^.*\/\([^/][^/]*\)\/*$/{ - s//\1/ - q - } - /^X\/\(\/\/\)$/{ - s//\1/ - q - } - /^X\/\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q' - -echo 'X/foo/bar' | \sed "$basename" +echo 'X/foo/bar' | \sed -f test/data/basename.sed diff --git a/test/data/basename.sed b/test/data/basename.sed new file mode 100644 index 0000000..86b8772 --- /dev/null +++ b/test/data/basename.sed @@ -0,0 +1,13 @@ +/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q From 1cda08dd4a8106a0a2b2dffd8f653f2be1c1d561 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Sun, 9 Dec 2018 15:43:26 -0500 Subject: [PATCH 312/312] sed: Replace blank regexes with the last regex. --- gash/commands/sed.scm | 50 ++++++++++++++++++++++++++++++++----------- 1 file changed, 37 insertions(+), 13 deletions(-) diff --git a/gash/commands/sed.scm b/gash/commands/sed.scm index 8f8d456..d7f9cc7 100644 --- a/gash/commands/sed.scm +++ b/gash/commands/sed.scm @@ -90,11 +90,34 @@ (define quit-tag (make-prompt-tag)) +(define (make-regexp-factory) + (let* ((previous-pattern #f) + (ht (make-hash-table)) + (make-regexp/memoized + (lambda args + (or (hash-ref ht args #f) + (let ((regexp (apply make-regexp args))) + (hash-set! ht args regexp) + regexp))))) + (lambda (pattern . flags) + (if (string-null? pattern) + (if previous-pattern + (apply make-regexp/memoized previous-pattern flags) + (error "SED: no previous regular expression")) + (begin + (set! previous-pattern pattern) + (apply make-regexp/memoized pattern flags)))))) + +(define regexp-factory + (make-parameter + (lambda _ + (error "SED: no regexp-factory available")))) + (define (substitute str pattern replacement flags) (let* ((global? (memq 'g flags)) (flags (cons (if (extended?) regexp/extended regexp/basic) (if (memq 'i flags) `(,regexp/icase) '()))) - (regexp (apply make-regexp (replace-escapes pattern) flags)) + (regexp (apply (regexp-factory) (replace-escapes pattern) flags)) (proc (replace->lambda (replace-escapes replacement) global?))) (match (list-matches regexp str) ((and m+ (_ _ ...)) (proc str m+)) @@ -104,7 +127,7 @@ (if (string? address) (let* ((flags `(,(if (extended?) regexp/extended regexp/basic))) (pattern (replace-escapes address)) - (regexp (apply make-regexp pattern flags))) + (regexp (apply (regexp-factory) pattern flags))) (cut regexp-exec regexp <>)) (error "SED: unsupported address type" address))) @@ -133,18 +156,19 @@ (define* (edit-stream commands #:optional (in (current-input-port)) (out (current-output-port))) - (let loop ((pattern-space (read-line in))) - (unless (eof-object? pattern-space) - (call-with-prompt quit-tag - (lambda () - (let ((result (execute-commands commands pattern-space))) + (parameterize ((regexp-factory (make-regexp-factory))) + (let loop ((pattern-space (read-line in))) + (unless (eof-object? pattern-space) + (call-with-prompt quit-tag + (lambda () + (let ((result (execute-commands commands pattern-space))) + (display result out) + (newline out) + (loop (read-line in)))) + (lambda (cont result) (display result out) - (newline out) - (loop (read-line in)))) - (lambda (cont result) - (display result out) - (newline out)))) - #t)) + (newline out)))) + #t))) (define (sed . args) (let* ((option-spec