ADDED COPYING Index: COPYING ================================================================== --- /dev/null +++ COPYING @@ -0,0 +1,724 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) 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 +this service 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 make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. 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. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute 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 and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +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 +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the 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 a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, 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. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE 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. + + 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 +convey 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 2 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, write to the Free Software + Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision 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, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This 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 Library General +Public License instead of this License. + + +GNU Free Documentation License +****************************** + + Version 1.1, March 2000 + Copyright (C) 2000 Free Software Foundation, Inc. + 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + + 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 + written 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 that contains a + notice placed by the copyright holder saying it can be distributed + under the terms of this License. The "Document", below, refers to + any such manual or work. Any member of the public is a licensee, + and is addressed as "you". + + 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. + (For example, 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. + + 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 "Transparent" copy of the Document means a machine-readable copy, + represented in a format whose specification is available to the + general public, whose contents can be viewed and edited directly + and 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 has been designed + to thwart or discourage subsequent modification by readers is not + Transparent. 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 designed for human modification. + Opaque formats include PostScript, PDF, 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 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. + + 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 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 publicly-accessible + computer-network location containing a complete Transparent copy + of the Document, free of added material, which the general + network-using public has access to download anonymously at no + charge using public-standard network protocols. 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 less than five). + + 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", and 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. In any section entitled "Acknowledgments" or "Dedications", + preserve the section's title, and preserve in the section all + the substance and tone of each of the contributor + acknowledgments 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 as "Endorsements" or to + conflict in title with any Invariant Section. + + 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. + + 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 + "Acknowledgments", 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, does not as a whole count as a + Modified Version of the Document, provided no compilation + copyright is claimed for the compilation. Such a compilation is + called an "aggregate", and this License does not apply to the + other self-contained works thus compiled with the Document, on + account of their being thus compiled, if they 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 + quarter of the entire aggregate, the Document's Cover Texts may be + placed on covers that surround only the Document within the + aggregate. Otherwise they must appear on covers around 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 provided that you also include the + original English version of this License. In case of a + disagreement between the translation and the original English + version of this License, the original English version will prevail. + + 9. TERMINATION + + You may not copy, modify, sublicense, or distribute the Document + except as expressly provided for under this License. Any other + attempt to copy, modify, sublicense or distribute the Document is + void, and will automatically terminate your rights under this + License. However, parties who have received copies, or rights, + from you under this License will not have their licenses + terminated so long as such parties remain in full compliance. + + 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 + `http://www.gnu.org/copyleft/'. + + 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. + +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.1 + or any later version published by the Free Software Foundation; + with the Invariant Sections being LIST THEIR TITLES, with the + Front-Cover Texts being LIST, and with the Back-Cover Texts being LIST. + A copy of the license is included in the section entitled ``GNU + Free Documentation License''. + + If you have no Invariant Sections, write "with no Invariant Sections" +instead of saying which ones are invariant. If you have no Front-Cover +Texts, write "no Front-Cover Texts" instead of "Front-Cover Texts being +LIST"; likewise for Back-Cover Texts. + + 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. + ADDED Makefile Index: Makefile ================================================================== --- /dev/null +++ Makefile @@ -0,0 +1,21 @@ +FILES=$(glob *.scm) + +megatest: common.scm configf.scm db.scm keys.scm launch.scm megatest.scm process.scm runs.scm gui.scm + csc megatest.scm + +dashboard: megatest + csc dashboard.scm + +$(PREFIX)/bin/megatest : megatest + @echo Installing to PREFIX=$(PREFIX), use ^C to cancel and change + sleep 5 + cp megatest $(PREFIX)/bin/megatest + +$(PREFIX)/bin/dashboard : dashboard + cp dashboard $(PREFIX)/bin/dashboard + +install : $(PREFIX)/bin/megatest $(PREFIX)/bin/dashboard + +test: megatest tests/tests.scm + cd tests;csi -I .. -b -n tests.scm + ADDED NOTES Index: NOTES ================================================================== --- /dev/null +++ NOTES @@ -0,0 +1,7 @@ +1. All run control access to db is direct. +2. All test machines must have megatest available +3. Tests may or may not have file system access to the originating + run area. rsync is used to pull the test area to the home host + if and only if the originating area can not be seen via file + system. NO LONGER TRUE. Rsync is used but file system must be visible. +4. All db access is done via the home host. NOT IMPLEMENTED YET. ADDED TODO Index: TODO ================================================================== --- /dev/null +++ TODO @@ -0,0 +1,15 @@ +1. Run all tests +2. create run areas, copy in conf and scripts DONE +3. Add a host chooser for ssh to launch-tests +4. Run creation timestamp not happening DONE +5 . Check for test already in progress, give meaningful message DONE +6. Debug xterm creation for test generation DONE +7. Capture run info, host, load, freemem at test launch DONE +8. Rename to testalot? Nah! I like Megatest +10. Run, test and step comment field +11. At end of test scan all tests for this run, if all done + update run status to COMPLETED NOT gonna happen. It is up to the test to mark as PASS/FAIL +12. state and status lists need to be regexes +13. Test on Chicken 4. DONE +14. Try making static executable +15. Log processor script DONE ADDED common.scm Index: common.scm ================================================================== --- /dev/null +++ common.scm @@ -0,0 +1,112 @@ +;;====================================================================== +;; Copyright 2006-2011, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(use sqlite3 srfi-1 posix regex-case base64 format) +(require-extension sqlite3 regex posix) + +(import (prefix sqlite3 sqlite3:)) +(import (prefix base64 base64:)) + +;; (require-library margs) +(include "margs.scm") + +(define getenv get-environment-variable) + +(define home (getenv "HOME")) +(define user (getenv "USER")) + +(define *configinfo* #f) +(define *configdat* #f) +(define *toppath* #f) +(define *already-seen-runconfig-info* #f) +(define *waiting-queue* (make-hash-table)) + +(define-inline (get-with-default val default) + (let ((val (args:get-arg val))) + (if val val default))) + +(define-inline (assoc/default key lst . default) + (let ((res (assoc key lst))) + (if res (cadr res)(if (null? default) #f (car default))))) + +;;====================================================================== +;; Misc utils +;;====================================================================== + +(define (get-df path) + (let* ((df-results (cmd-run->list (conc "df " path))) + (space-rx (regexp "([0-9]+)\\s+([0-9]+)%")) + (freespc #f)) + ;; (write df-results) + (for-each (lambda (l) + (let ((match (string-search space-rx l))) + (if match + (let ((newval (string->number (cadr match)))) + (if (number? newval) + (set! freespc newval)))))) + (car df-results)) + freespc)) + +(define (get-cpu-load) + (let* ((load-res (cmd-run->list "uptime")) + (load-rx (regexp "load average:\\s+(\\d+)")) + (cpu-load #f)) + (for-each (lambda (l) + (let ((match (string-search load-rx l))) + (if match + (let ((newval (string->number (cadr match)))) + (if (number? newval) + (set! cpu-load newval)))))) + (car load-res)) + cpu-load)) + +(define (get-uname . params) + (let* ((uname-res (cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) + (uname #f)) + (if (null? (car uname-res)) + "unknown" + (caar uname-res)))) + +(define (save-environment-as-files fname) + (let ((envvars (get-environment-variables)) + (whitesp (regexp "[^a-zA-Z0-9_\\-:;,.\\/%]"))) + (with-output-to-file (conc fname ".csh") + (lambda () + (for-each (lambda (key) + (let* ((val (cdr key)) + (sval (if (string-search whitesp val)(conc "'" val "'") val))) + (print "setenv " (car key) " " sval))) + envvars))) + (with-output-to-file (conc fname ".sh") + (lambda () + (for-each (lambda (key) + (let* ((val (cdr key)) + (sval (if (string-search whitesp val)(conc "'" val "'") val))) + (print "export " (car key) "=" sval))) + envvars))))) + +;; set some env vars from an alist, return an alist with original values +;; (("VAR" "value") ...) +(define (alist->env-vars lst) + (if (list? lst) + (let ((res '())) + (for-each (lambda (p) + (let* ((var (car p)) + (val (cadr p)) + (prv (get-environment-variable var))) + (set! res (cons (list var prv) res)) + (if val + (setenv var (->string val)) + (unsetenv var)))) + lst) + res) + '())) + ADDED configf.scm Index: configf.scm ================================================================== --- /dev/null +++ configf.scm @@ -0,0 +1,87 @@ +;;====================================================================== +;; Copyright 2006-2011, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +;;====================================================================== +;; Config file handling +;;====================================================================== + +;; return list (path fullpath configname) +(define (find-config configname) + (let* ((cwd (string-split (current-directory) "/"))) + (let loop ((dir cwd)) + (let* ((path (conc "/" (string-intersperse dir "/"))) + (fullpath (conc path "/" configname))) + (if (file-exists? fullpath) + (list path fullpath configname) + (let ((remcwd (take dir (- (length dir) 1)))) + (if (null? remcwd) + (list #f #f #f) ;; #f #f) + (loop remcwd)))))))) + +(define (config:assoc-safe-add alist key val) + (let ((newalist (filter (lambda (x)(not (equal? key x))) alist))) + (append alist (list (list key val))))) + +;; read a config file, returns two level hierarchial hash-table, +;; adds to ht if given (must be #f otherwise) +(define (read-config path . ht) + (if (not (file-exists? path)) + (if (null? ht)(make-hash-table) (car ht)) + (let ((inp (open-input-file path)) + (res (if (null? ht)(make-hash-table)(car ht))) + (include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) + (section-rx (regexp "^\\[(.*)\\]\\s*$")) + (blank-l-rx (regexp "^\\s*$")) + (key-val-pr (regexp "^(\\S+)\\s+(.*)$")) + (comment-rx (regexp "^\\s*#.*"))) + (let loop ((inl (read-line inp)) + (curr-section-name "default")) + (if (eof-object? inl) res + (regex-case + inl + (comment-rx _ (loop (read-line inp) curr-section-name)) + (blank-l-rx _ (loop (read-line inp) curr-section-name)) + (include-rx ( x include-file ) (begin + (read-config include-file res) + (loop (read-line inp) curr-section-name))) + (section-rx ( x section-name ) (loop (read-line inp) section-name)) + (key-val-pr ( x key val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key val)) + ;; (append alist (list (list key val)))) + (loop (read-line inp) curr-section-name))) + (else (print "ERROR: Should not get here,\n \"" inl "\"") + (loop (read-line inp) curr-section-name)))))))) + +(define (find-and-read-config fname) + (let* ((configinfo (find-config fname)) + (toppath (car configinfo)) + (configfile (cadr configinfo)) + (configdat (if configfile (read-config configfile) #f))) ;; (make-hash-table)))) + (list configdat toppath configfile fname))) + +(define (config-lookup cfgdat section var) + (let ((sectdat (hash-table-ref/default cfgdat section '()))) + (if (null? sectdat) + #f + (let ((match (assoc var sectdat))) + (if match + (cadr match) + #f)) + ))) + +(define (setup) + (let* ((configf (find-config)) + (config (if configf (read-config configf) #f))) + (if config + (setenv "RUN_AREA_HOME" (pathname-directory configf))) + config)) + ADDED dashboard.scm Index: dashboard.scm ================================================================== --- /dev/null +++ dashboard.scm @@ -0,0 +1,415 @@ +;;====================================================================== +;; Copyright 2006-2011, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(require-library iup) +(import (prefix iup iup:)) + +;; (use canvas-draw) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69) + +(import (prefix sqlite3 sqlite3:)) + +(include "../margs/margs.scm") +(include "keys.scm") +(include "items.scm") +(include "db.scm") +(include "configf.scm") +(include "process.scm") +(include "launch.scm") +(include "runs.scm") +(include "gui.scm") + +(if (not (setup-for-run)) + (begin + (print "Failed to find megatest.config, exiting") + (exit 1))) + +(define *db* (open-db)) + +(define toplevel #f) +(define dlg #f) +(define max-test-num 0) +(define *keys* (get-keys *db*)) +(define dbkeys (map (lambda (x)(vector-ref x 0)) + (append *keys* (list (vector "runname" "blah"))))) +(define *header* #f) +(define *allruns* '()) +(define *buttondat* (make-hash-table)) ;; +(define *alltestnames* (make-hash-table)) ;; build a minimalized list of test names +(define *alltestnamelst* '()) +(define *searchpatts* (make-hash-table)) +(define *num-runs* 10) +(define *num-tests* 15) +(define *start-run-offset* 0) +(define *start-test-offset* 0) + + +(define (message-window msg) + (iup:show + (iup:dialog + (iup:vbox + (iup:label msg #:margin "40x40"))))) + +(define (iuplistbox-fill-list lb items . default) + (let ((i 1) + (selected-item (if (null? default) #f (car default)))) + (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) + (for-each (lambda (item) + (iup:attribute-set! lb (number->string i) item) + (if selected-item + (if (equal? selected-item item) + (iup:attribute-set! lb "VALUE" item))) ;; (number->string i)))) + (set! i (+ i 1))) + items) + i)) + +(define (pad-list l n)(append l (make-list (- n (length l))))) + +(define (examine-test button-key) ;; run-id run-key origtest) + (let ((buttondat (hash-table-ref/default *buttondat* button-key #f))) + ;; (print "buttondat: " buttondat) + (if (and buttondat + (vector buttondat) + (vector-ref buttondat 0) + (> (vector-ref buttondat 0) 0) + (vector? (vector-ref buttondat 3)) + (> (vector-ref (vector-ref buttondat 3) 0) 0)) + (let* ((run-id (vector-ref buttondat 0)) + (origtest (vector-ref buttondat 3)) + (run-key (vector-ref buttondat 4)) + (test (db:get-test-info *db* + run-id + (db:test-get-testname origtest) + (db:test-get-item-path origtest))) + (rundir (db:test-get-rundir test)) + (testname (db:test-get-testname test)) + (itempath (db:test-get-item-path test)) + (testfullname (runs:test-get-full-path test)) + (currstatus (db:test-get-status test)) + (currstate (db:test-get-state test)) + (currcomment (db:test-get-comment test)) + (logfile (conc (db:test-get-rundir test) "/" (db:test-get-final_logf test))) + (viewlog (lambda (x) + (if (file-exists? logfile) + (system (conc "firefox " logfile "&")) + (message-window (conc "File " logfile " not found"))))) + (xterm (lambda (x) + (if (directory-exists? rundir) + (system (conc "cd " rundir ";xterm -T " (string-translate testfullname "()" " ") "&")) + (message-window (conc "Directory " rundir " not found"))))) + (newstatus currstatus) + (newstate currstate) + (self #f)) + + ;; (test-set-status! db run-id test-name state status itemdat) + (set! self + (iup:dialog + (iup:vbox + (iup:hbox + (iup:frame (iup:label run-key)) + (iup:frame (iup:label (conc "TESTNAME:\n" testfullname) #:expand "YES"))) + (iup:frame #:title "Actions" #:expand "YES" + (iup:hbox ;; the actions box + (iup:button "View Log" #:action viewlog #:expand "YES") + (iup:button "Start Xterm" #:action xterm #:expand "YES"))) + (iup:frame #:title "Set fields" + (iup:vbox + (iup:hbox + (iup:vbox ;; the state + (iup:label "STATE:" #:size "30x") + (let ((lb (iup:listbox #:action (lambda (val a b c) + ;; (print val " a: " a " b: " b " c: " c) + (set! newstate a)) + #:editbox "YES" + #:expand "YES"))) + (iuplistbox-fill-list lb + (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ") + currstate) + lb)) + (iup:vbox ;; the status + (iup:label "STATUS:" #:size "30x") + (let ((lb (iup:listbox #:action (lambda (val a b c) + (set! newstatus a)) + #:editbox "YES" + #:value currstatus + #:expand "YES"))) + (iuplistbox-fill-list lb + (list "PASS" "FAIL" "n/a") + currstatus) + lb))) + (iup:hbox (iup:label "Comment:") + (iup:textbox #:action (lambda (val a b) + (set! currcomment b)) + #:value currcomment + #:expand "YES")) + (iup:button "Apply" + #:expand "YES" + #:action (lambda (x) + (test-set-status! *db* run-id testname newstate newstatus itempath currcomment))) + (iup:hbox (iup:button "Apply and close" + #:expand "YES" + #:action (lambda (x) + (test-set-status! *db* run-id testname newstate newstatus itempath currcomment) + (iup:destroy! self))) + (iup:button "Cancel and close" + #:expand "YES" + #:action (lambda (x) + (iup:destroy! self)))) + ))))) + (iup:show self) + )))) + +(define (colors-similar? color1 color2) + (let* ((c1 (map string->number (string-split color1))) + (c2 (map string->number (string-split color2))) + (delta (map (lambda (a b)(abs (- a b))) c1 c2))) + (null? (filter (lambda (x)(> x 3)) delta)))) + +(define (update-rundat patt numruns) + (let* ((allruns (db-get-runs *db* patt numruns *start-run-offset*)) + (header (db:get-header allruns)) + (runs (db:get-rows allruns)) + (result '()) + (maxtests 0)) + (for-each (lambda (run) + (let* ((run-id (db-get-value-by-header run header "id")) + (tests (db-get-tests-for-run *db* run-id)) + (key-vals (get-key-vals *db* run-id))) + (if (> (length tests) maxtests) + (set! maxtests (length tests))) + (set! result (cons (vector run tests key-vals) result)))) + runs) + (set! *header* header) + (set! *allruns* (reverse result)) + maxtests)) + +(define (update-labels uidat) + (let* ((rown 0) + (lftcol (vector-ref uidat 0)) + (maxn (- (vector-length lftcol) 1))) + (let loop ((i 0)) + (iup:attribute-set! (vector-ref lftcol i) "TITLE" "") + (if (<= i rown) + (loop (+ i 1)))) + (for-each (lambda (name) + (if (<= rown maxn) + (let ((labl (vector-ref lftcol rown))) + (iup:attribute-set! labl "TITLE" name))) + (set! rown (+ 1 rown))) + (drop *alltestnamelst* *start-test-offset*)))) + +(define (update-buttons uidat numruns numtests) + (let* ((runs (if (> (length *allruns*) numruns) + (take-right *allruns* numruns) + (pad-list *allruns* numruns))) + (lftcol (vector-ref uidat 0)) + (tableheader (vector-ref uidat 1)) + (table (vector-ref uidat 2)) + (coln 0)) + (update-labels uidat) + (for-each + (lambda (rundat) + (if (not rundat) ;; handle padded runs + ;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration + (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3))) + (let* ((run (vector-ref rundat 0)) + (testsdat (vector-ref rundat 1)) + (key-val-dat (vector-ref rundat 2)) + (run-id (db-get-value-by-header run *header* "id")) + (testnames (delete-duplicates (append *alltestnamelst* + (map test:test-get-fullname testsdat)))) ;; (take (pad-list testsdat numtests) numtests)) + (key-vals (append key-val-dat + (list (let ((x (db-get-value-by-header run *header* "runname"))) + (if x x ""))))) + (run-key (string-intersperse key-vals "\n"))) + ;; (run-ht (hash-table-ref/default alldat run-key #f))) + ;; fill in the run header key values + (let ((rown 0) + (headercol (vector-ref tableheader coln))) + (for-each (lambda (kval) + (let* ((labl (vector-ref headercol rown))) + (if (not (equal? kval (iup:attribute labl "TITLE"))) + (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval)) + (set! rown (+ rown 1)))) + key-vals)) + + ;; For this run now fill in the buttons for each test + (let ((rown 0) + (columndat (vector-ref table coln))) + (for-each + (lambda (testname) + (let ((buttondat (hash-table-ref/default *buttondat* (mkstr coln rown) #f))) + (if buttondat + (let* ((test (let ((matching (filter + (lambda (x)(equal? (test:test-get-fullname x) testname)) + testsdat))) + (if (null? matching) + (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") + (car matching)))) + ;; (test (if real-test real-test + (testname (db:test-get-testname test)) + (itempath (db:test-get-item-path test)) + (testfullname (test:test-get-fullname test)) + (teststatus (db:test-get-status test)) + (teststate (db:test-get-state test)) + (buttontxt (if (equal? teststate "COMPLETED") teststatus teststate)) + (button (vector-ref columndat rown)) + (color (case (string->symbol teststate) + ((COMPLETED) + (if (equal? teststatus "PASS") "70 249 73" "223 33 49")) ;; greenish redish + ((LAUNCHED) "101 123 142") + ((REMOTEHOSTSTART) "50 130 195") + ((RUNNING) "9 131 232") + ((KILLREQ) "39 82 206") + ((KILLED) "234 101 17") + (else "192 192 192"))) + (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) + (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) + (if (not (equal? curr-color color)) + (iup:attribute-set! button "BGCOLOR" color)) + (if (not (equal? curr-title buttontxt)) + (iup:attribute-set! button "TITLE" buttontxt)) + (vector-set! buttondat 0 run-id) + (vector-set! buttondat 1 color) + (vector-set! buttondat 2 buttontxt) + (vector-set! buttondat 3 test) + (vector-set! buttondat 4 run-key) + (if (not (hash-table-ref/default *alltestnames* testfullname #f)) + (begin + (hash-table-set! *alltestnames* testfullname #t) + (set! *alltestnamelst* (append *alltestnamelst* (list testfullname)))))) + ) + (set! rown (+ rown 1)))) + (drop testnames *start-test-offset*))) + (set! coln (+ coln 1)))) + runs))) + +(define (mkstr . x) + (string-intersperse (map conc x) ",")) + +(define (update-search x val) + (print "Setting search for " x " to " val) + (hash-table-set! *searchpatts* x val)) + +(define (make-dashboard-buttons nruns ntests keynames) + (let* ((nkeys (length keynames)) + (runsvec (make-vector nruns)) + (header (make-vector nruns)) + (lftcol (make-vector ntests)) + (controls '()) + (lftlst '()) + (hdrlst '()) + (bdylst '()) + (result '()) + (i 0)) + ;; controls (along bottom) + (set! controls + (iup:hbox + (iup:button "Quit" #:action (lambda (obj)(sqlite3:finalize! *db*)(exit))) + (iup:button "<- Left" #:action (lambda (obj)(set! *start-run-offset* (+ *start-run-offset* 1)))) + (iup:button "Up ^" #:action (lambda (obj)(set! *start-test-offset* (if (> *start-test-offset* 0)(- *start-test-offset* 1) 0)))) + (iup:button "Down v" #:action (lambda (obj)(set! *start-test-offset* (if (>= *start-test-offset* (length *alltestnamelst*))(length *alltestnamelst*)(+ *start-test-offset* 1))))) + (iup:button "Right ->" #:action (lambda (obj)(set! *start-run-offset* (if (> *start-run-offset* 0)(- *start-run-offset* 1) 0)))))) + + ;; create the left most column for the run key names and the test names + (set! lftlst (list (apply iup:vbox + (map (lambda (x) + (let ((res (iup:hbox + (iup:label x #:size "40x15" #:fontsize "10") ;; #:expand "HORIZONTAL") + (iup:textbox #:size "60x15" #:fontsize "10" #:value "%" ;; #:expand "HORIZONTAL" + #:action (lambda (obj unk val) + (update-search x val)))))) + (set! i (+ i 1)) + res)) + keynames)))) + (let loop ((testnum 0) + (res '())) + (cond + ((>= testnum ntests) + ;; now lftlst will be an hbox with the test keys and the test name labels + (set! lftlst (append lftlst (list (apply iup:vbox (reverse res)))))) + (else + (let ((labl (iup:button "" #:flat "YES" #:size "100x15" #:fontsize "10"))) + (vector-set! lftcol testnum labl) + (loop (+ testnum 1)(cons labl res)))))) + ;; + (let loop ((runnum 0) + (keynum 0) + (keyvec (make-vector nkeys)) + (res '())) + (cond ;; nb// no else for this approach. + ((>= runnum nruns) #f) + ((>= keynum nkeys) + (vector-set! header runnum keyvec) + (set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst)) + (loop (+ runnum 1) 0 (make-vector nkeys) '())) + (else + (let ((labl (iup:label "" #:size "60x15" #:fontsize "10" ;; #:expand "HORIZONTAL" + ))) + (vector-set! keyvec keynum labl) + (loop runnum (+ keynum 1) keyvec (cons labl res)))))) + ;; By here the hdrlst contains a list of vboxes containing nkeys labels + (let loop ((runnum 0) + (testnum 0) + (testvec (make-vector ntests)) + (res '())) + (cond + ((>= runnum nruns) #f) ;; (vector tableheader runsvec)) + ((>= testnum ntests) + (vector-set! runsvec runnum testvec) + (set! bdylst (cons (apply iup:vbox (reverse res)) bdylst)) + (loop (+ runnum 1) 0 (make-vector ntests) '())) + (else + (let* ((button-key (mkstr runnum testnum)) + (butn (iup:button "" ;; button-key + #:size "60x15" + ;; #:expand "HORIZONTAL" + #:fontsize "10" + #:action (lambda (x) + (examine-test button-key))))) + (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) + (vector-set! testvec testnum butn) + (loop runnum (+ testnum 1) testvec (cons butn res)))))) + ;; now assemble the hdrlst and bdylst and kick off the dialog + (iup:show + (iup:dialog + #:title "Megatest dashboard" + (iup:vbox + (apply iup:hbox + (cons (apply iup:vbox lftlst) + (list + (iup:vbox + ;; the header + (apply iup:hbox (reverse hdrlst)) + (apply iup:hbox (reverse bdylst)))))) + controls))) + (vector lftcol header runsvec))) + +(set! *num-tests* (max (update-rundat "%" *num-runs*) 8)) + +(set! uidat (make-dashboard-buttons *num-runs* *num-tests* dbkeys)) +;; (megatest-dashboard) + +(define (run-update other-thread) + (let loop ((i 0)) + (thread-sleep! 0.1) + (thread-suspend! other-thread) + (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs*) + (update-buttons uidat *num-runs* *num-tests*) + (thread-resume! other-thread) + (loop (+ i 1)))) + +(define th2 (make-thread iup:main-loop)) +(define th1 (make-thread (run-update th2))) +(thread-start! th1) +(thread-start! th2) +(thread-join! th2) ADDED db.scm Index: db.scm ================================================================== --- /dev/null +++ db.scm @@ -0,0 +1,281 @@ +;;====================================================================== +;; Copyright 2006-2011, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +;;====================================================================== +;; Database access +;;====================================================================== + +(define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) + (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) + (configdat (car *configinfo*)) + (dbexists (file-exists? dbpath)) + (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) + (handler (make-busy-timeout 36000))) + (sqlite3:set-busy-handler! db handler) + (if (not dbexists) + (let* ((keys (config-get-fields configdat)) + (havekeys (> (length keys) 0)) + (keystr (keys->keystr keys)) + (fieldstr (keys->key/field keys))) + ;; (sqlite3:execute db "PRAGMA synchronous = OFF;") + (sqlite3:execute db "CREATE TABLE keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") + (for-each (lambda (key) + (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" (key:get-fieldname key)(key:get-fieldtype key))) + keys) + (sqlite3:execute db (conc + "CREATE TABLE runs (id INTEGER PRIMARY KEY, " + fieldstr (if havekeys "," "") + "runname TEXT," + "state TEXT DEFAULT ''," + "status TEXT DEFAULT ''," + "owner TEXT DEFAULT ''," + "event_time TIMESTAMP," + "comment TEXT DEFAULT ''," + "CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) + (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");")) + (sqlite3:execute db + "CREATE TABLE tests + (id INTEGER PRIMARY KEY, + run_id INTEGER, + testname TEXT, + itempath TEXT, + host TEXT DEFAULT 'n/a', + cpuload REAL DEFAULT -1, + diskfree INTEGER DEFAULT -1, + uname TEXT DEFAULT 'n/a', + rundir TEXT DEFAULT 'n/a', + item_path TEXT DEFAULT '', + state TEXT DEFAULT 'NOT_STARTED', + status TEXT DEFAULT 'n/a', + attemptnum INTEGER DEFAULT 0, + final_logf TEXT DEFAULT 'logs/final.log', + logdat BLOB, + run_duration INTEGER DEFAULT 0, + comment TEXT DEFAULT '', + event_time TIMESTAMP, + CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path) + );") + (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname);") + (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") + (sqlite3:execute db "CREATE TABLE test_steps + (id INTEGER PRIMARY KEY, + test_id INTEGER, + stepname TEXT, + state TEXT DEFAULT 'NOT_STARTED', + status TEXT DEFAULT 'n/a',event_time TIMESTAMP, + comment TEXT DEFAULT '', + CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") + (sqlite3:execute db "CREATE TABLE extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") + (sqlite3:execute db "CREATE TABLE access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);"))) + db)) + +;; (if (args:get-arg "-db") +;; (set! db (open-db (args:get-arg "-db")))) + +;; TODO +;; +;; 1. Implement basic registering of records +;; 2. Implement basic querying of records +;; eh? + +(define (db-get-keys db) + (let ((res '())) + (sqlite3:for-each-row + (lambda (key keytype) + (set! res (cons (vector key keytype) res))) + db + "SELECT fieldname,fieldtype FROM keys ORDER BY id DESC;") + res)) + + +(define-inline (db:get-header vec)(vector-ref vec 0)) +(define-inline (db:get-rows vec)(vector-ref vec 1)) + +(define (db-get-value-by-header row header field) + (if (null? header) #f + (let loop ((hed (car header)) + (tal (cdr header)) + (n 0)) + (if (equal? hed field) + (vector-ref row n) + (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))) + +(define (db-get-runs db runpatt . count) + (let* ((res '()) + (keys (db-get-keys db)) + (remfields (list "id" "runname" "state" "status" "owner" "event_time")) + (header (append (map key:get-fieldname keys) + remfields)) + (keystr (conc (keys->keystr keys) "," + (string-intersperse remfields ",")))) + (sqlite3:for-each-row + (lambda (a . x) + (set! res (cons (apply vector a x) res))) + db + (conc "SELECT " keystr " FROM runs WHERE runname LIKE ? ORDER BY event_time DESC " + (if (and (not (null? count)) + (number? (car count))) + (conc " LIMIT " (car count)) + "") + (if (and (> (length count) 1) + (number? (cadr count))) + (conc " OFFSET " (cadr count)) + "")) + runpatt) + (vector header res))) + +;; use this one for db-get-run-info +(define-inline (db:get-row vec)(vector-ref vec 1)) + +;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) +(define (db-get-run-info db run-id) + (let* ((res #f) + (keys (db-get-keys db)) + (remfields (list "id" "runname" "state" "status" "owner" "event_time")) + (header (append (map key:get-fieldname keys) + remfields)) + (keystr (conc (keys->keystr keys) "," + (string-intersperse remfields ",")))) + (sqlite3:for-each-row + (lambda (a . x) + (set! res (apply vector a x))) + db + (conc "SELECT " keystr " FROM runs WHERE id=?;") + run-id) + (vector header res))) + +;; Tests +(define (make-db:test)(make-vector 6)) +(define-inline (db:test-get-id vec) (vector-ref vec 0)) +(define-inline (db:test-get-run_id vec) (vector-ref vec 1)) +(define-inline (db:test-get-testname vec) (vector-ref vec 2)) +(define-inline (db:test-get-state vec) (vector-ref vec 3)) +(define-inline (db:test-get-status vec) (vector-ref vec 4)) +(define-inline (db:test-get-event_time vec) (vector-ref vec 5)) +(define-inline (db:test-get-host vec) (vector-ref vec 6)) +(define-inline (db:test-get-cpuload vec) (vector-ref vec 7)) +(define-inline (db:test-get-diskfree vec) (vector-ref vec 8)) +(define-inline (db:test-get-uname vec) (vector-ref vec 9)) +(define-inline (db:test-get-rundir vec) (vector-ref vec 10)) +(define-inline (db:test-get-item-path vec) (vector-ref vec 11)) +(define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) +(define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) +(define-inline (db:test-get-comment vec) (vector-ref vec 14)) + +(define (db-get-tests-for-run db run-id) + (let ((res '())) + (sqlite3:for-each-row + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) + (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) + db + "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE run_id=? ORDER BY id DESC;" + run-id) + res)) + +;; NB// Sync this with runs:get-test-info +(define (db:get-test-info db run-id testname item-path) + (let ((res '())) + (sqlite3:for-each-row + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment) + (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment))) + db + "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path=?;" + run-id testname item-path) + res)) + +;; Steps +;; Run steps +;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time +(define (make-db:step)(make-vector 6)) +(define-inline (db:step-get-id vec) (vector-ref vec 0)) +(define-inline (db:step-get-test_id vec) (vector-ref vec 1)) +(define-inline (db:step-get-stepname vec) (vector-ref vec 2)) +(define-inline (db:step-get-state vec) (vector-ref vec 3)) +(define-inline (db:step-get-status vec) (vector-ref vec 4)) +(define-inline (db:step-get-event_time vec) (vector-ref vec 5)) +(define-inline (db:step-set-id! vec val)(vector-set! vec 0 val)) +(define-inline (db:step-set-test_id! vec val)(vector-set! vec 1 val)) +(define-inline (db:step-set-stepname! vec val)(vector-set! vec 2 val)) +(define-inline (db:step-set-state! vec val)(vector-set! vec 3 val)) +(define-inline (db:step-set-status! vec val)(vector-set! vec 4 val)) +(define-inline (db:step-set-event_time! vec val)(vector-set! vec 5 val)) + +(define (db-get-test-steps-for-run db test-id) + (let ((res '())) + (sqlite3:for-each-row + (lambda (id test-id stepname state status event-time) + (set! res (cons (vector id test-id stepname state status event-time) res))) + db + "SELECT id,test_id,stepname,state,status,event_time FROM test_steps WHERE test_id=? ORDER BY event_time DESC;" + test-id) + res)) + +;; check that *all* the prereqs are "COMPLETED" +(define (db-get-prereqs-met db run-id waiton) + (let ((res #f) + (not-complete 0) + (tests (db-get-tests-for-run db run-id))) + (for-each + (lambda (test-name) + (for-each + (lambda (test) + (if (equal? (db:test-get-testname test) test-name) + (begin + (set! res #t) + (if (not (equal? (db:test-get-state test) "COMPLETED")) + (set! not-complete (+ 1 not-complete)))))) + tests)) + waiton) + (and (or (null? waiton) res) + (eq? not-complete 0)))) + +;; USE: (lset-difference string=? '("a" "b" "c") '("d" "c" "e" "a")) +;; +;; Return a list of prereqs that were NOT met +;; Tests (and all items) in waiton list must be "COMPLETED" and "PASS" +(define (db-get-prereqs-not-met db run-id waiton) + (if (null? waiton) + '() + (let* ((unmet-pre-reqs '()) + (tests (db-get-tests-for-run db run-id)) + (result '())) + (for-each (lambda (waitontest-name) + (let ((ever-seen #f)) + (for-each (lambda (test) + (if (equal? waitontest-name (db:test-get-testname test)) + (begin + (set! ever-seen #t) + (if (not (and (equal? (db:test-get-state test) "COMPLETED") + (equal? (db:test-get-status test) "PASS"))) + (set! result (cons waitontest-name result)))))) + tests) + (if (not ever-seen)(set! result (cons waitontest-name result))))) + waiton) + (delete-duplicates result)))) +;; +;; ;; subtract from the waiton list the "COMPLETED" tests +;; ;;(completed-tests (filter (lambda (x) +;; ;; (equal? (db:test-get-state x) "COMPLETED")) +;; ;; tests)) +;; (completed-tests (let ((non-completed (make-hash-table))) +;; (for-each (lambda (x) +;; ;; could add check for PASS here +;; (if (not (and (equal? (db:test-get-state x) "COMPLETED") +;; (equal? (db:test-get-status x) "PASS"))) +;; (hash-table-set! non-completed (db:test-get-testname x) x))) +;; ;; (print "Completed: " (db:test-get-testname x)))) +;; tests) +;; (filter (lambda (x) +;; (not (hash-table-ref/default non-completed (db:test-get-testname x) #f))) +;; tests))) +;; (pre-dep-names (map db:test-get-testname completed-tests)) +;; (result (lset-difference string=? waiton pre-dep-names))) +;; (print "pre-dep-names: " pre-dep-names " waiton: " waiton " result: " result) ADDED docs/screenshot.png Index: docs/screenshot.png ================================================================== --- /dev/null +++ docs/screenshot.png cannot compute difference between binary files ADDED gui.scm Index: gui.scm ================================================================== --- /dev/null +++ gui.scm @@ -0,0 +1,58 @@ + +;; Copyright 2006-2011, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +;; (define (celsius->fahrenheit item) +;; (let ((number (string->number item))) +;; (if (number? number) +;; (+ (* number 9/5) 32) +;; 0.0))) + +;; (define (megatest-gui-1) +;; (use pstk) +;; (handle-exceptions +;; exn +;; (tk-end) ; make sure tk is closed in event of any error +;; +;; (tk-start) +;; (tk/wm 'title tk "Celsius to Fahrenheit") +;; (let* ((celsius (tk 'create-widget 'entry)) +;; (label (tk 'create-widget 'label)) +;; (button (tk 'create-widget 'button +;; 'text: 'Calculate +;; 'command: (lambda () +;; (label 'configure +;; 'text: (number->string (celsius->fahrenheit (celsius 'get)))))))) +;; ; layout widgets in a grid +;; (tk/grid celsius 'column: 2 'row: 1 'sticky: 'we 'padx: 5 'pady: 5) +;; (tk/grid label 'column: 2 'row: 2 'sticky: 'we 'padx: 5 'pady: 5) +;; (tk/grid button 'column: 2 'row: 3 'sticky: 'we 'padx: 5 'pady: 5) +;; (tk/grid (tk 'create-widget 'label 'text: "celsius") +;; 'column: 3 'row: 1 'sticky: 'w 'padx: 5 'pady: 5) +;; (tk/grid (tk 'create-widget 'label 'text: "is") +;; 'column: 1 'row: 2 'sticky: 'e 'padx: 5 'pady: 5) +;; (tk/grid (tk 'create-widget 'label 'text: "fahrenheit") +;; 'column: 3 'row: 2 'sticky: 'w 'padx: 5 'pady: 5) ; begin program +;; ; rest of gui setup +;; (tk-event-loop)) +;; )) + +(define (init-dialog) + ;; (let ((controls-frame (iup:frame + ;; (iup:hbox + #t) + +;; For now the gui work will be done in dashboard.scm + +;;(define (megatest-gui) +;; (require-library iup) +;; (import (prefix iup iup:)) +;; (use canvas-draw canvas-draw-iup) +;; (use srfi-4)) + ADDED items.scm Index: items.scm ================================================================== --- /dev/null +++ items.scm @@ -0,0 +1,65 @@ + +;; Copyright 2006-2011, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + + +;; (define itemdat '((ripeness "green ripe overripe") +;; (temperature "cool medium hot") +;; (season "summer winter fall spring"))) + +;; Mostly worked = puts out all combinations? +(define (process-itemlist-try1 curritemkey itemlist) + (let loop ((hed (car itemlist)) + (tal (cdr itemlist))) + (if (null? tal) + (for-each (lambda (item) + (print "curritemkey: " (append curritemkey (list item)))) + (cadr hed)) + (begin + (for-each (lambda (item) + (process-itemlist (append curritemkey (list item)) tal)) + (cadr hed)) + (loop (car tal)(cdr tal)))))) + +;; Mostly worked = puts out all combinations? +(define (process-itemlist hierdepth curritemkey itemlist) + (let ((res '())) + (if (not hierdepth) + (set! hierdepth (length itemlist))) + (let loop ((hed (car itemlist)) + (tal (cdr itemlist))) + (if (null? tal) + (for-each (lambda (item) + (if (> (length curritemkey) (- hierdepth 2)) + (set! res (append res (list (append curritemkey (list (list (car hed) item)))))))) + (cadr hed)) + (begin + (for-each (lambda (item) + (set! res (append res (process-itemlist hierdepth (append curritemkey (list (list (car hed) item))) tal)))) + (cadr hed)) + (loop (car tal)(cdr tal))))) + res)) + +(define (item-assoc->item-list itemsdat) + (if (and itemsdat (not (null? itemsdat))) + (let ((itemlst (map (lambda (x) + (let ((name (car x)) + (items (cadr x))) + (list name (string-split items)))) + itemsdat))) + (process-itemlist #f '() itemlst)) + '(()))) ;; return a list consisting on a single null list for non-item runs + +(define-inline (item-list->path itemdat) + (string-intersperse (map cadr itemdat) "/")) + +;; (pp (item-assoc->item-list itemdat)) + + + ADDED keys.scm Index: keys.scm ================================================================== --- /dev/null +++ keys.scm @@ -0,0 +1,96 @@ + +;; Copyright 2006-2011, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +;;====================================================================== +;; Run keys, these are used to hierarchially organise tests and run areas +;;====================================================================== + + +(define-inline (key:get-fieldname key)(vector-ref key 0)) +(define-inline (key:get-fieldtype key)(vector-ref key 1)) + +(define (get-keys db) + (let ((keys '())) ;; keys are vectors + (sqlite3:for-each-row (lambda (fieldname fieldtype) + (set! keys (cons (vector fieldname fieldtype) keys))) + db + "SELECT fieldname,fieldtype FROM keys ORDER BY id ASC;") + (reverse keys))) ;; could just sort desc? + +;; get key vals for a given run-id +(define (get-key-vals db run-id) + (let* ((keys (get-keys db)) + (res '())) + ;; (print "keys: " keys " run-id: " run-id) + (for-each + (lambda (key) + (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) + ;; (print "qry: " qry) + (sqlite3:for-each-row + (lambda (key-val) + (set! res (cons key-val res))) + db qry run-id))) + keys) + (reverse res))) + +(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... + (string-intersperse (map key:get-fieldname keys) ",")) + +(define-inline (keys->valslots keys) ;; => ?,?,? .... + (string-intersperse (map (lambda (x) "?") keys) ",")) + +(define-inline (keys->key/field keys . additional) + (string-join (map (lambda (k)(conc (key:get-fieldname k) " " (key:get-fieldtype k)))(append keys additional)) ",")) + +(define (args:usage . a) #f) + +;; Using the keys pulled from the database (initially set from the megatest.config file) +;; look for the equivalent value on the command line and add it to a list, or #f if not found. +;; default => (val1 val2 val3 ...) +;; withkey => (:key1 val1 :key2 val2 :key3 val3 ...) +(define (keys->vallist keys . withkey) ;; ORDERING IS VERY IMPORTANT, KEEP PROPER ORDER HERE! + (let* ((keynames (map key:get-fieldname keys)) + (argkeys (map (lambda (k)(conc ":" k)) keynames)) + (withkey (not (null? withkey))) + (newremargs (args:get-args (cons "blah" remargs) argkeys '() args:arg-hash 0))) ;; the cons blah works around a bug in args [args assumes ("calling-prog-name" .... ) ] + ;;(print "remargs: " remargs " newremargs: " newremargs) + (apply append (map (lambda (x) + (let ((val (args:get-arg x))) + ;; (print "x: " x " val: " val) + (if (not val) + ;; (print "WARNING: missing key " x ". Specified in database but not on command line, using \"unk\"") + (set! val "default")) + (if withkey (list x val) (list val)))) + argkeys)))) + +;; (define (keys->alist keys) +;; (let* ((keynames (map key:get-fieldname keys)) +;; (argkeys (map (lambda (k)(conc ":" k)) keynames)) +;; (withkey (not (null? withkey))) +;; (newremargs (args:get-args (cons "blah" remargs) argkeys '() args:arg-hash 0))) ;; the cons blah works around a bug in args +;; (print "remargs: " remargs " newremargs: " newremargs) +;; (apply append (map (lambda (x) +;; (let ((val (args:get-arg x))) +;; (if (not val) +;; (print "ERROR: Ignoring key " x " found in database but not on command line")) +;; (if withkey (list x val) (list val)))) +;; argkeys)))) + +(define (keystring->keys keystring) + (map (lambda (x) + (let ((xlst (string-split x ":"))) + (list->vector (if (> (length xlst) 1) xlst (append (car xlst)(list "TEXT")))))) + (delete-duplicates (string-split keystring ",")))) + +(define (config-get-fields confdat) + (let ((fields (hash-table-ref/default confdat "fields" '()))) + (map (lambda (x)(vector (car x)(cadr x))) + fields))) + ADDED launch.scm Index: launch.scm ================================================================== --- /dev/null +++ launch.scm @@ -0,0 +1,157 @@ + +;; Copyright 2006-2011, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +;;====================================================================== +;; launch a task - this runs on the originating host, tests themselves +;; +;;====================================================================== + +(define (setup-for-run) + (set! *configinfo* (find-and-read-config (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config"))) + (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) + (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) + (if *toppath* + (setenv "MT_RUN_AREA_HOME" *toppath*) + (print "ERROR: failed to find the top path to your run setup.")) + *toppath*) + +(define (setup-env-defaults db fname run-id . already-seen) + (let* ((keys (get-keys db)) + (keyvals (get-key-vals db run-id)) + (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")) + (confdat (read-config fname)) + (whatfound (make-hash-table)) + (sections (list "default" thekey))) + ;; (print "Using key=\"" thekey "\"") + (for-each + (lambda (section) + (let ((section-dat (hash-table-ref/default confdat section #f))) + (if section-dat + (for-each + (lambda (envvar) + (hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1)) + (setenv envvar (cadr (assoc envvar section-dat)))) + (map car section-dat))))) + sections) + (if (and (not (null? already-seen)) + (not (car already-seen))) + (begin + (print "Key settings found in runconfig.config:") + (for-each (lambda (fullkey) + (format #t "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0))) + sections) + (print "---") + (set! *already-seen-runconfig-info* #t))))) + +(define (get-best-disk confdat) + (let* ((disks (hash-table-ref/default confdat "disks" #f)) + (best #f) + (bestsize 0)) + (if disks + (for-each + (lambda (disk-num) + (let* ((dirpath (cadr (assoc disk-num disks))) + (freespc (if (directory? dirpath) + (get-df dirpath) + (begin + (print "WARNING: path " dirpath " in [disks] section not valid") + 0)))) + (if (> freespc bestsize) + (begin + (set! best dirpath) + (set! bestsize freespc))))) + (map car disks))) + best)) + +(define (create-work-area db run-id test-path disk-path testname itemdat) + (let* ((run-info (db-get-run-info db run-id)) + (item-path (let ((ip (item-list->path itemdat))) + (if (equal? ip "") "" (conc "/" ip)))) + (runname (db-get-value-by-header (db:get-row run-info) + (db:get-header run-info) + "runname")) + (key-vals (get-key-vals db run-id)) + (key-str (string-intersperse key-vals "/")) + (dfullp (conc disk-path "/" key-str "/" runname "/" testname + item-path)) + (lnkpath (conc *toppath* "/runs/" key-str "/" runname item-path))) + (print "Setting up test run area") + (print " - creating run area in " dfullp) + (system (conc "mkdir -p " dfullp)) + (print " - creating link from " dfullp "/" testname " to " lnkpath) + (system (conc "mkdir -p " lnkpath)) + (if (file-exists? (conc lnkpath "/" testname)) + (system (conc "rm -f " lnkpath "/" testname))) + (system (conc "ln -sf " dfullp " " lnkpath "/" testname)) + (if (directory? dfullp) + (begin + (system (conc "rsync -av " test-path "/ " dfullp "/")) + dfullp) + #f))) + +;; 1. look though disks list for disk with most space +;; 2. create run dir on disk, path name is meaningful +;; 3. create link from run dir to megatest runs area +;; 4. remotely run the test on allocated host +;; - could be ssh to host from hosts table (update regularly with load) +;; - could be netbatch +;; (launch-test db (cadr status) test-conf)) +(define (launch-test db run-id test-conf keyvallst test-name test-path itemdat) + (let ((launcher (config-lookup *configdat* "jobtools" "launcher")) + (runscript (config-lookup test-conf "setup" "runscript")) + (diskspace (config-lookup test-conf "requirements" "diskspace")) + (memory (config-lookup test-conf "requirements" "memory")) + (hosts (config-lookup *configdat* "jobtools" "workhosts")) + (remote-megatest (config-lookup *configdat* "setup" "executable")) + (local-megatest (car (argv))) + ;; (item-path (item-list->path itemdat)) test-path is the full path including the item-path + (work-area #f) + (diskpath #f) + (cmdparms #f) + (fullcmd #f));; (define a (with-output-to-string (lambda ()(write x)))) + (if hosts (set! hosts (string-split hosts))) + (if (not remote-megatest)(set! remote-megatest "megatest")) + (if launcher (set! launcher (string-split launcher))) + ;; set up the run work area for this test + (set! diskpath (get-best-disk *configdat*)) + (if diskpath + (set! work-area (create-work-area db run-id test-path diskpath test-name itemdat)) + (begin + (set! work-area test-path) + (print "WARNING: No disk work area specified - running in the test directory"))) + (set! cmdparms (base64:base64-encode (with-output-to-string + (lambda () ;; (list 'hosts hosts) + (write (list (list 'testpath test-path) + (list 'work-area work-area) + (list 'test-name test-name) + (list 'runscript runscript) + (list 'run-id run-id ) + (list 'itemdat itemdat))))))) ;; (string-intersperse keyvallst " ")))) + (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir + (cond + ((and launcher hosts) ;; must be using ssh hostname + (set! fullcmd (append launcher (car hosts)(list remote-megatest "-execute" cmdparms)))) + (launcher + (set! fullcmd (append launcher (list remote-megatest "-execute" cmdparms)))) + (else + (set! fullcmd (list remote-megatest "-execute" cmdparms)))) + (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) + (print "Launching megatest for test " test-name " in " work-area" ...") + (test-set-status! db run-id test-name "LAUNCHED" "n/a" itemdat) ;; (if launch-results launch-results "FAILED")) + ;; set "pre-launch-env-vars + (let* ((prevvals (alist->env-vars + (hash-table-ref/default test-conf "pre-launch-env-overrides" '()))) + (launch-results (apply cmd-run-proc-each-line + (car fullcmd) + print + (cdr fullcmd)))) ;; launcher fullcmd)));; (apply cmd-run-proc-each-line launcher print fullcmd))) ;; (cmd-run->list fullcmd)) + (print "Launching completed, updating db") + (alist->env-vars prevvals)))) + ADDED margs.scm Index: margs.scm ================================================================== --- /dev/null +++ margs.scm @@ -0,0 +1,62 @@ +;; Copyright 2007-2010, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +(define args:arg-hash (make-hash-table)) + +(define (args:get-arg arg . default) + (if (null? default) + (hash-table-ref/default args:arg-hash arg #f) + (hash-table-ref/default args:arg-hash arg (car default)))) + +(define (args:get-arg-from ht arg . default) + (if (null? default) + (hash-table-ref/default ht arg #f)) + (hash-table-ref/default ht arg (car default))) + +(define (args:usage . args) + (if (> (length args) 0) + (apply print "ERROR: " args)) + (if (string? help) + (print help) + (print "Usage: " (car (argv)) " ... ")) + (exit 0)) + +;; args: +(define (args:get-args args params switches arg-hash num-needed) + (let* ((numargs (length args)) + (adj-num-needed (if num-needed (+ num-needed 2) #f))) + (if (< numargs (if adj-num-needed adj-num-needed 2)) + (if (>= num-needed 1) + (args:usage "No arguments provided")) + (let loop ((arg (cadr args)) + (tail (cddr args)) + (remargs '())) + (cond + ((member arg params) ;; args with params + (if (< (length tail) 1) + (args:usage "param given without argument " arg) + (let ((val (car tail)) + (newtail (cdr tail))) + (hash-table-set! arg-hash arg val) + (if (null? newtail) remargs + (loop (car newtail)(cdr newtail) remargs))))) + ((member arg switches) ;; args with no params (i.e. switches) + (hash-table-set! arg-hash arg #t) + (if (null? tail) remargs + (loop (car tail)(cdr tail) remargs))) + (else + (if (null? tail)(append remargs (list arg)) ;; return the non-used args + (loop (car tail)(cdr tail)(append remargs (list arg)))))))) + )) + +(define (args:print-args remargs arg-hash) + (print "ARGS: " remargs) + (for-each (lambda (arg) + (print " " arg " " (hash-table-ref/default arg-hash arg #f))) + (hash-table-keys arg-hash))) ADDED megatest.scm Index: megatest.scm ================================================================== --- /dev/null +++ megatest.scm @@ -0,0 +1,476 @@ +;; Copyright 2006-2011, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +(include "common.scm") +(define megatest-version 1.0) + +(define help (conc " +Megatest, documentation at http://www.kiatoa.com/fossils/opensrc + version " megatest-version " + license GPL, Copyright Matt Welland 2006-2011 + +Usage: megatest [options] + -h : this help + +Process and test running + -runall : run all tests that are not state COMPLETED and status PASS + -runtests tst1,tst2 ... : run tests + +Run status updates (these require that you are in a test directory + and you have sourced the \"megatest.csh\" or + \"megatest.sh\" file.) + -step stepname + -test-status : set the state and status of a test (use :state and :status) + -setlog logfname : set the path/filename to the final log relative to the test + directory. may be used with -test-status + -m comment : insert a comment for this test + +Run data: + + :runname : required, name for this particular test run + :state : required if updating step state; e.g. start, end, completed + :status : required if updating step status; e.g. pass, fail, n/a + +Queries + -list-runs patt : list runs matching pattern \"patt\", % is the wildcard + -showkeys : show the keys used in this megatest setup + +Misc (note: there is a bug in argument processing, put these at the beginning + of the command line or it may fail) + -force : override some checks + -xterm : start an xterm instead of launching the test + +Helpers + + -runstep stepname ... : take leftover params as comand and execute as stepname + log will be in stepname.log + -logpro file : with -exec apply logpro file to stepname.log, creates + stepname.html and sets log to same + +Called as " (string-intersperse (argv) " "))) + +;; -gui : start a gui interface +;; -config fname : override the runconfig file with fname + +;; process args +(define remargs (args:get-args + (argv) + (list "-runtests" ;; run a specific test + "-config" ;; override the config file name + "-execute" ;; run the command encoded in the base64 parameter + "-step" + ":runname" + ":item" + ":runname" + ":state" + ":status" + "-list-runs" + "-setlog" + "-runstep" + "-logpro" + ) + (list "-h" + "-force" + "-xterm" + "-showkeys" + "-test-status" + "-gui" + "-runall" ;; run all tests + + ) + args:arg-hash + 0)) + +(if (args:get-arg "-h") + (begin + (print help) + (exit))) + +(include "keys.scm") +(include "items.scm") +(include "db.scm") +(include "configf.scm") +(include "process.scm") +(include "launch.scm") +(include "runs.scm") +;; (include "gui.scm") + +(define *didsomething* #f) + +;;====================================================================== +;; Query runs +;;====================================================================== + +(if (args:get-arg "-list-runs") + (let* ((db (begin + (setup-for-run) + (open-db))) + (runpatt (args:get-arg "-list-runs")) + (runsdat (db-get-runs db runpatt)) + (runs (db:get-rows runsdat)) + (header (db:get-header runsdat)) + (keys (db-get-keys db)) + (keynames (map key:get-fieldname keys))) + ;; Each run + (for-each + (lambda (run) + (print "Run: " + (string-intersperse (map (lambda (x) + (db-get-value-by-header run header x)) + keynames) "/") + "/" + (db-get-value-by-header run header "runname")) + (let ((run-id (db-get-value-by-header run header "id"))) + (let ((tests (db-get-tests-for-run db run-id))) + ;; Each test + (for-each + (lambda (test) + (format #t + " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" + (conc (db:test-get-testname test) + (if (equal? (db:test-get-item-path test) "") + "" + (conc "(" (db:test-get-item-path test) ")"))) + (db:test-get-state test) + (db:test-get-status test) + (db:test-get-run_duration test) + (db:test-get-event_time test) + (db:test-get-host test)) + (if (not (or (equal? (db:test-get-status test) "PASS") + (equal? (db:test-get-state test) "NOT_STARTED"))) + (begin + (print " cpuload: " (db:test-get-cpuload test) + "\n diskfree: " (db:test-get-diskfree test) + "\n uname: " (db:test-get-uname test) + "\n rundir: " (db:test-get-rundir test) + ) + ;; Each test + (let ((steps (db-get-test-steps-for-run db (db:test-get-id test)))) + (for-each + (lambda (step) + (format #t + " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" + (db:step-get-stepname step) + (db:step-get-state step) + (db:step-get-status step) + (db:step-get-event_time step))) + ;; (print " Step: " (db:step-get-stepname step) + ;; " " (db:step-get-state step) + ;; " " (db:step-get-status step) + ;; " " (db:step-get-event_time step))) + steps))))) + tests)))) + runs) + (set! *didsomething* #t) + )) + +;;====================================================================== +;; full run +;;====================================================================== + +;; get lock in db for full run for this directory +;; for all tests with deps +;; walk tree of tests to find head tasks +;; add head tasks to task queue +;; add dependant tasks to task queue +;; add remaining tasks to task queue +;; for each task in task queue +;; if have adequate resources +;; launch task +;; else +;; put task in deferred queue +;; if still ok to run tasks +;; process deferred tasks per above steps + +;; run all tests are are Not COMPLETED and PASS or CHECK +(if (args:get-arg "-runall") + (if (not (args:get-arg ":runname")) + (begin + (print "ERROR: Missing required parameter for -runtests, you must specify the run name with :runname runname") + (exit 2)) + (let* ((db (if (setup-for-run) + (open-db) + (begin + (print "Failed to setup, exiting") + (exit 1))))) + (if (not (car *configinfo*)) + (begin + (print "ERROR: Attempted to run a test but run area config file not found") + (exit 1)) + ;; put test parameters into convenient variables + (let* ((test-names (get-all-legal-tests))) ;; "PROD" is ignored for now + (print "INFO: Attempting to start the following tests...") + (print " " (string-intersperse test-names ",")) + (run-tests db test-names))) + (run-waiting-tests db) + (sqlite3:finalize! db) + (set! *didsomething* #t)))) + +;;====================================================================== +;; run one test +;;====================================================================== + +;; 1. find the config file +;; 2. change to the test directory +;; 3. update the db with "test started" status, set running host +;; 4. process launch the test +;; - monitor the process, update stats in the db every 2^n minutes +;; 5. as the test proceeds internally it calls megatest as each step is +;; started and completed +;; - step started, timestamp +;; - step completed, exit status, timestamp +;; 6. test phone home +;; - if test run time > allowed run time then kill job +;; - if cannot access db > allowed disconnect time then kill job + +(define (runtests) + (if (not (args:get-arg ":runname")) + (begin + (print "ERROR: Missing required parameter for -runtests, you must specify the run name with :runname runname") + (exit 2)) + (let ((db #f)) + (if (not (setup-for-run)) + (begin + (print "Failed to setup, exiting") + (exit 1))) + (set! db (open-db)) + (if (not (car *configinfo*)) + (begin + (print "ERROR: Attempted to run a test but run area config file not found") + (exit 1)) + ;; put test parameters into convenient variables + (let* ((test-names (string-split (args:get-arg "-runtests") ","))) + (run-tests db test-names))) + ;; run-waiting-tests db) + (sqlite3:finalize! db) + (run-waiting-tests #f) + (set! *didsomething* #t)))) + +(if (args:get-arg "-runtests") + (runtests)) + +;;====================================================================== +;; execute the test +;; - gets called on remote host +;; - receives info from the -execute param +;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file) +;; - gathers host info and +;;====================================================================== + +(if (args:get-arg "-execute") + (let* ((cmdinfo (read (open-input-string (base64:base64-decode (args:get-arg "-execute")))))) + (setenv "MT_CMDINFO" (args:get-arg "-execute")) + (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) + (let* ((testpath (assoc/default 'testpath cmdinfo)) + (work-area (assoc/default 'work-area cmdinfo)) + (test-name (assoc/default 'test-name cmdinfo)) + (runscript (assoc/default 'runscript cmdinfo)) + (db-host (assoc/default 'db-host cmdinfo)) + (run-id (assoc/default 'run-id cmdinfo)) + (itemdat (assoc/default 'itemdat cmdinfo)) + (fullrunscript (conc testpath "/" runscript)) + (db #f)) + (print "Exectuing " test-name " on " (get-host-name)) + (change-directory testpath) + (if (not (setup-for-run)) + (begin + (print "Failed to setup, exiting") + (exit 1))) + ;; now can find our db + (set! db (open-db)) + (change-directory work-area) + (let ((runconfigf (conc *toppath* "/runconfigs.config"))) + (if (file-exists? runconfigf) + (setup-env-defaults db runconfigf run-id) + (print "WARNING: You do not have a run config file: " runconfigf))) + (set-megatest-env-vars db run-id) + (set-item-env-vars itemdat) + (save-environment-as-files "megatest") + (test-set-meta-info db run-id test-name itemdat) + (test-set-status! db run-id test-name "REMOTEHOSTSTART" "n/a" itemdat (args:get-arg "-m")) + (if (args:get-arg "-xterm") + (set! fullrunscript "xterm") + (if (not (file-execute-access? fullrunscript)) + (system (conc "chmod ug+x " fullrunscript)))) + ;; We are about to actually kick off the test + ;; so this is a good place to remove the records for + ;; any previous runs + ;; (db:test-remove-steps db run-id testname itemdat) + + ;; from here on out we will open and close the db + ;; on every access to reduce the probablitiy of + ;; contention or stuck access on nfs. + (sqlite3:finalize! db) + + (let* ((m (make-mutex)) + (kill-job? #f) + (exit-info (make-vector 3)) + (runit (lambda () + (let-values + (((pid exit-status exit-code) + (run-n-wait fullrunscript))) + (mutex-lock! m) + (vector-set! exit-info 0 pid) + (vector-set! exit-info 1 exit-status) + (vector-set! exit-info 2 exit-code) + (mutex-unlock! m)))) + (monitorjob (lambda () + (let* ((start-seconds (current-seconds)) + (calc-minutes (lambda () + (inexact->exact + (round + (- + (current-seconds) + start-seconds)))))) + (let loop ((minutes (calc-minutes))) + (let ((db (open-db))) + (set! kill-job? (test-get-kill-request db run-id test-name itemdat)) + (test-update-meta-info db run-id test-name itemdat minutes) + (if kill-job? (process-signal (vector-ref exit-info 0) signal/term)) + (sqlite3:finalize! db) + (thread-sleep! (+ 8 (random 4))) ;; add some jitter to the call home time to spread out the db accesses + (loop (calc-minutes))))))) + (th1 (make-thread monitorjob)) + (th2 (make-thread runit))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th2) + (mutex-lock! m) + (set! db (open-db)) + (let* ((testinfo (runs:get-test-info db run-id test-name (item-list->path itemdat)))) + (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) + (begin + (print "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result") + (test-set-status! db run-id test-name + (if kill-job? "KILLED" "COMPLETED") + (if (vector-ref exit-info 1) ;; look at the exit-status + (if (eq? (vector-ref exit-info 2) 0) + "PASS" + "FAIL") + "FAIL") itemdat (args:get-arg "-m"))))) + (mutex-unlock! m) + ;; (exec-results (cmd-run->list fullrunscript)) ;; (list ">" (conc test-name "-run.log")))) + ;; (success exec-results)) ;; (eq? (cadr exec-results) 0))) + (print "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " + work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n") + (sqlite3:finalize! db) + (if (not (vector-ref exit-info 1)) + (exit 4))))) + (set! *didsomething* #t))) + +(if (args:get-arg "-step") + (if (not (getenv "MT_CMDINFO")) + (begin + (print "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") + (exit 5)) + (let* ((step (args:get-arg "-step")) + (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) + (testpath (assoc/default 'testpath cmdinfo)) + (test-name (assoc/default 'test-name cmdinfo)) + (runscript (assoc/default 'runscript cmdinfo)) + (db-host (assoc/default 'db-host cmdinfo)) + (run-id (assoc/default 'run-id cmdinfo)) + (itemdat (assoc/default 'itemdat cmdinfo)) + (db #f) + (state (args:get-arg ":state")) + (status (args:get-arg ":status"))) + (change-directory testpath) + (if (not (setup-for-run)) + (begin + (print "Failed to setup, exiting") + (exit 1))) + (set! db (open-db)) + (if (and state status) + (teststep-set-status! db run-id test-name step state status itemdat) + (begin + (print "ERROR: You must specify :state and :status with every call to -step") + (exit 6))) + (sqlite3:finalize! db) + (set! *didsomething* #t)))) + +(if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status + (args:get-arg "-test-status") + (args:get-arg "-runstep")) + (if (not (getenv "MT_CMDINFO")) + (begin + (print "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") + (exit 5)) + (let* ((cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) + (testpath (assoc/default 'testpath cmdinfo)) + (test-name (assoc/default 'test-name cmdinfo)) + (runscript (assoc/default 'runscript cmdinfo)) + (db-host (assoc/default 'db-host cmdinfo)) + (run-id (assoc/default 'run-id cmdinfo)) + (itemdat (assoc/default 'itemdat cmdinfo)) + (db #f) + (state (args:get-arg ":state")) + (status (args:get-arg ":status"))) + (change-directory testpath) + (if (not (setup-for-run)) + (begin + (print "Failed to setup, exiting") + (exit 1))) + (set! db (open-db)) + (if (args:get-arg "-setlog") + (test-set-log! db run-id test-name itemdat (args:get-arg "-setlog"))) + (if (args:get-arg "-test-status") + (test-set-status! db run-id test-name state status itemdat (args:get-arg "-m")) + (if (and state status) + (if (not (args:get-arg "-setlog")) + (begin + (print "ERROR: You must specify :state and :status with every call to -test-status\n" help) + (sqlite3:finalize! db) + (exit 6))))) + (if (args:get-arg "-run-step") + (if (null? remargs) + (begin + (print "ERROR: nothing specified to run!") + (sqlite3:finalize! db) + (exit 6)) + (let* ((logprofile (args:get-arg "-logpro")) + (cmd (if (null? remargs) #f (car remargs))) + (params (if cmd (cdr remargs) #f)) + (exitstat #f)) + ;; mark the start of the test + (test-set-status! db run-id test-name "start" "n/a" itemdat (args:get-arg "-m")) + ;; close the db + (sqlite3:finalize! db) + ;; run the test step + (set! exitstat (process-run cmd params)) + ;; run logpro if applicable + (if logpro + (set! exitstat (process-run "logpro" logpro (conc test-name ".html")))) + (test-set-status! db run-id test-name "end" FINISH MEEEEE!!!!!! + ;; open the db + ;; mark the end of the test + )) + (sqlite3:finalize! db) + (set! *didsomething* #t)))) + +(if (args:get-arg "-showkeys") + (let ((db #f) + (keys #f)) + (if (not (setup-for-run)) + (begin + (print "Failed to setup, exiting") + (exit 1))) + (set! db (open-db)) + (set! keys (db-get-keys db)) + (print "Keys: " (string-intersperse (map key:get-fieldname keys) ", ")) + (sqlite3:finalize! db) + (set! *didsomething* #t))) + +(if (args:get-arg "-gui") + (begin + (print "Look at the dashboard for now") + ;; (megatest-gui) + (set! *didsomething* #t))) + +(if (not *didsomething*) + (print help)) ADDED process.scm Index: process.scm ================================================================== --- /dev/null +++ process.scm @@ -0,0 +1,67 @@ +;;====================================================================== +;; Copyright 2006-2011, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +;;====================================================================== +;; Process convience utils +;;====================================================================== + +(define (cmd-run-proc-each-line cmd proc . params) + (let* ((fh (process cmd params))) + (let loop ((curr (read-line fh)) + (result '())) + (if (not (eof-object? curr)) + (loop (read-line fh) + (append result (list (proc curr)))) + result)))) + +(define (cmd-run-proc-each-line-alt cmd proc) + (let* ((fh (open-input-pipe cmd)) + (res (port-proc->list fh proc)) + (status (close-input-pipe fh))) + (if (eq? status 0) res #f))) + +(define (cmd-run->list cmd) + (let* ((fh (open-input-pipe cmd)) + (res (port->list fh)) + (status (close-input-pipe fh))) + (list res status))) + +(define (port->list fh) + (if (eof-object? fh) #f + (let loop ((curr (read-line fh)) + (result '())) + (if (not (eof-object? curr)) + (loop (read-line fh) + (append result (list curr))) + result)))) + +(define (port-proc->list fh proc) + (if (eof-object? fh) #f + (let loop ((curr (proc (read-line fh))) + (result '())) + (if (not (eof-object? curr)) + (loop (let ((l (read-line fh))) + (if (eof-object? l) l (proc l))) + (append result (list curr))) + result)))) + +;; here is an example line where the shell is sh or bash +;; "find / -print 2&>1 > findall.log" +(define (run-n-wait cmdline) + (let ((pid (process-run cmdline))) + (let loop ((i 0)) + (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) + (if (eq? pid-val 0) + (begin + (thread-sleep! 2) + (loop (+ i 1))) + (values pid-val exit-status exit-code)))))) + ADDED runs.scm Index: runs.scm ================================================================== --- /dev/null +++ runs.scm @@ -0,0 +1,299 @@ + +;; Copyright 2006-2011, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') + +;; register a test run with the db +(define (register-run db keys) ;; test-name) + (let* ((keystr (keys->keystr keys)) + (comma (if (> (length keys) 0) "," "")) + (andstr (if (> (length keys) 0) " AND " "")) + (valslots (keys->valslots keys)) ;; ?,?,? ... + (keyvallst (keys->vallist keys)) + (runname (get-with-default ":runname" #f)) + (state (get-with-default ":state" "no")) + (status (get-with-default ":status" "n/a")) + (allvals (append (list runname state status user) keyvallst)) + (qryvals (append (list runname) keyvallst)) + (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND "))) + ;; (print "keys: " keys " allvals: " allvals " keyvallst: " keyvallst) + (print "NOTE: using key " (string-intersperse keyvallst "/") " for this run") + (if (and runname (null? (filter (lambda (x)(not x)) keyvallst))) ;; there must be a better way to "apply and" + (let ((res #f)) + (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") + allvals) + (apply sqlite3:for-each-row + (lambda (id) + (set! res id)) + db + (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) + ;; (print "qry: " qry) + qry) + qryvals) + (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res) + res) + (begin + (print "ERROR: Called without all necessary keys") + #f)))) + +(define (register-test db run-id test-name item-path) + (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path) VALUES (?,?,strftime('%s','now'),?);" run-id test-name item-path)) + +(define (test-set-status! db run-id test-name state status itemdat-or-path . comment) + (let ((item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path)))) + (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" + state status run-id test-name item-path) + (if (and (not (null? comment)) + (car comment)) + (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" + (car comment) run-id test-name item-path)))) + +(define (test-set-log! db run-id test-name itemdat logf) + (let ((item-path (item-list->path itemdat))) + (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;" + logf run-id test-name item-path))) + +;; TODO: Converge this with db:get-test-info +(define (runs:get-test-info db run-id test-name item-path) + (let ((res #f)) ;; (vector #f #f #f #f #f #f))) + (sqlite3:for-each-row + (lambda (id run-id test-name state status) + (set! res (vector id run-id test-name state status item-path))) + db "SELECT id,run_id,testname,state,status FROM tests WHERE run_id=? AND testname=? AND item_path=?;" + run-id test-name item-path) + res)) + +(define-inline (test:get-id vec) (vector-ref vec 0)) +(define-inline (test:get-run_id vec) (vector-ref vec 1)) +(define-inline (test:get-test-name vec)(vector-ref vec 2)) +(define-inline (test:get-state vec) (vector-ref vec 3)) +(define-inline (test:get-status vec) (vector-ref vec 4)) +(define-inline (test:get-item-path vec)(vector-ref vec 5)) + +(define (runs:test-get-full-path test) + (let* ((testname (db:test-get-testname test)) + (itempath (db:test-get-item-path test))) + (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) + +(define-inline (test:test-get-fullname test) + (conc (db:test-get-testname test) + (if (equal? (db:test-get-item-path test) "") + "" + (conc "(" (db:test-get-item-path test) ")")))) + +(define (check-valid-items class item) + (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class))) + (if s (string-split s) #f)))) + (if valid-values + (if (member item valid-values) + item #f) + item))) + +(define (teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat) + ;; (print "run-id: " run-id " test-name: " test-name) + (let* ((state (check-valid-items "state" state-in)) + (status (check-valid-items "status" status-in)) + (item-path (item-list->path itemdat)) + (testdat (runs:get-test-info db run-id test-name item-path))) + ;; (print "testdat: " testdat) + (if (and testdat ;; if the section exists then force specification BUG, I don't like how this works. + (or (not state)(not status))) + (print "WARNING: Invalid " (if status "status" "state") + " value \"" (if status status-in state-in) "\", update your validstates section in megatest.config")) + (if testdat + (let ((test-id (test:get-id testdat))) + (sqlite3:execute db + "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time) VALUES(?,?,?,?,strftime('%s','now'));" + test-id teststep-name state status)) + (print "ERROR: Can't update " test-name " for run " run-id " -> no such test in db")))) + +(define (test-get-kill-request db run-id test-name itemdat) + (let* ((item-path (item-list->path itemdat)) + (testdat (runs:get-test-info db run-id test-name item-path))) + (equal? (test:get-state testdat) "KILLREQ"))) + +(define (test-set-meta-info db run-id testname itemdat) + (let ((item-path (item-list->path itemdat)) + (cpuload (get-cpu-load)) + (hostname (get-host-name)) + (diskfree (get-df (current-directory))) + (uname (get-uname "-srvpio")) + (runpath (current-directory))) + (sqlite3:execute db "UPDATE tests SET host=?,cpuload=?,diskfree=?,uname=?,rundir=? WHERE run_id=? AND testname=? AND item_path=?;" + hostname + cpuload + diskfree + uname + runpath + run-id + testname + item-path))) + +(define (test-update-meta-info db run-id testname itemdat minutes) + (let ((item-path (item-list->path itemdat)) + (cpuload (get-cpu-load)) + (diskfree (get-df (current-directory)))) + (if (not cpuload) (begin (print "WARNING: CPULOAD not found.") (set! cpuload "n/a"))) + (if (not diskfree) (begin (print "WARNING: DISKFREE not found.") (set! diskfree "n/a"))) + (if (not item-path)(begin (print "WARNING: ITEMPATH not set.") (set! item-path ""))) + ;; (let ((testinfo (db:get-test-info db run-id testname item-path))) + ;; (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED")) + ;; (not (equal? (db:test-get-status testinfo) "KILLREQ")) + (sqlite3:execute + db + "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE run_id=? AND testname=? AND item_path=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');" + cpuload + diskfree + minutes + run-id + testname + item-path))) + +(define (set-megatest-env-vars db run-id) + (let ((keys (db-get-keys db))) + (for-each (lambda (key) + (sqlite3:for-each-row + (lambda (val) + (print "setenv " (key:get-fieldname key) " " val) + (setenv (key:get-fieldname key) val)) + db + (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;") + run-id)) + keys))) + +(define (set-item-env-vars itemdat) + (for-each (lambda (item) + (print "setenv " (car item) " " (cadr item)) + (setenv (car item) (cadr item))) + itemdat)) + +(define (get-all-legal-tests) + (let* ((tests (glob (conc *toppath* "/tests/*"))) + (res '())) + ;; (print "INFO: Looking at tests " (string-intersperse tests ",")) + (for-each (lambda (testpath) + (if (file-exists? (conc testpath "/testconfig")) + (set! res (cons (last (string-split testpath "/")) res)))) + tests) + res)) + +(define (run-tests db test-names) + (for-each + (lambda (test-name) + (run-one-test db test-name)) + test-names)) + +(define (run-one-test db test-name) + (print "Launching test " test-name) + (let* ((test-path (conc *toppath* "/tests/" test-name)) + (test-configf (conc test-path "/testconfig")) + (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) + (test-conf (if testexists (read-config test-configf) (make-hash-table))) + (waiton (let ((w (config-lookup test-conf "requirements" "waiton"))) + (if (string? w)(string-split w)'())))) + (if (not testexists) + (begin + (print "ERROR: Can't find config file " test-configf) + (exit 2)) + ;; put top vars into convenient variables and open the db + (let* (;; db is always at *toppath*/db/megatest.db + (keys (db-get-keys db)) + (keyvallst (keys->vallist keys #t)) + (items (hash-table-ref/default test-conf "items" #f)) + (allitems (item-assoc->item-list items)) + (run-id (register-run db keys)) ;; test-name))) + (runconfigf (conc *toppath* "/runconfigs.config"))) + ;; (print "items: ")(pp allitems) + (let loop ((itemdat (car allitems)) + (tal (cdr allitems))) + ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) + (let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/")) + (new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) + (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique + (test-status #f)) + (let loop2 ((ts #f) + (ct 0)) + (if (and (not ts) + (< ct 10)) + (begin + (register-test db run-id test-name item-path) + (loop2 (runs:get-test-info db run-id test-name item-path) + (+ ct 1))) + (if ts + (set! test-status ts) + (begin + (print "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping") + (if (not (null? tal)) + (loop (car tal)(cdr tal))))))) + (change-directory test-path) + ;; this block is here only to inform the user early on + (if (file-exists? runconfigf) + (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*) + (print "WARNING: You do not have a run config file: " runconfigf)) + ;; (print "run-id: " run-id " test-name: " test-name " item-path: " item-path " test-status: " (test:get-status test-status) " test-state: " (test:get-state test-status)) + (case (if (args:get-arg "-force") + 'NOT_STARTED + (if test-status + (string->symbol (test:get-state test-status)) + 'failed-to-insert)) + ((failed-to-insert) + (print "ERROR: Failed to insert the record into the db")) + ((NOT_STARTED COMPLETED) ;; (cadr status is the row id for the run record) + (if (and (equal? (test:get-state test-status) "COMPLETED") + (equal? (test:get-status test-status) "PASS") + (not (args:get-arg "-force"))) + (print "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"PASS\", use -force to override") + (let* ((get-prereqs-cmd (lambda () + (db-get-prereqs-not-met db run-id waiton))) ;; check before running .... + (launch-cmd (lambda () + (launch-test db run-id test-conf keyvallst test-name test-path itemdat))) + (testrundat (list get-prereqs-cmd launch-cmd))) + (if (or (args:get-arg "-force") + (null? ((car testrundat)))) ;; are there any tests that must be run before this one... + ((cadr testrundat)) ;; this is the line that launches the test to the remote host + (hash-table-set! *waiting-queue* new-test-name testrundat))))) + ((LAUNCHED REMOTEHOSTSTART KILLED) + (print "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) + ((RUNNING) (print "NOTE: " test-name " is already running")) + (else (print "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state test-status))))) + (if (not (null? tal)) + (loop (car tal)(cdr tal)))))))) + +(define (run-waiting-tests db) + (let ((numtries 0) + (last-try-time (current-seconds)) + (times (list 1))) ;; minutes to wait before trying again to kick off runs + ;; BUG this hack of brute force retrying works quite well for many cases but + ;; what is needed is to check the db for tests that have failed less than + ;; N times or never been started and kick them off again + (let loop ((waiting-test-names (hash-table-keys *waiting-queue*))) + (cond + ((null? waiting-test-names) + (print "All tests launched")) + ((> numtries 4) + (print "NOTE: Tried launching four times, perhaps run megatest again in a few minutes")) + (else + (set! numtries (+ numtries 1)) + (for-each (lambda (testname) + (let* ((testdat (hash-table-ref *waiting-queue* testname)) + (prereqs ((car testdat))) + (ldb (if db db (open-db)))) + ;; (print "prereqs remaining: " prereqs) + (if (null? prereqs) + (begin + (print "Prerequisites met, launching " testname) + ((cadr testdat)) + (hash-table-delete! *waiting-queue* testname))) + (if (not db) + (sqlite3:finalize! ldb)))) + waiting-test-names) + (sleep 10) ;; no point in rushing things at this stage? + (loop (hash-table-keys *waiting-queue*))))))) + ADDED tests/Makefile Index: tests/Makefile ================================================================== --- /dev/null +++ tests/Makefile @@ -0,0 +1,5 @@ +# run some tests + +runall : + megatest -runall :sysname ubuntu :fsname nfs :datapath none :runname `date +%GWW%V.%u` + ADDED tests/megatest.config Index: tests/megatest.config ================================================================== --- /dev/null +++ tests/megatest.config @@ -0,0 +1,27 @@ +[fields] +sysname TEXT +fsname TEXT +datapath TEXT + +[setup] +executable megatest + +[jobtools] +# ## launcher launches jobs, the job is managed on the target host +## by megatest, comment out launcher to run local +# workhosts localhost hermes +launcher nbfake + +[validvalues] +state start end completed +status pass fail n/a + +[env-override] +SPECIAL_ENV_VARS overide them here - all tests see these + +## disks are: +## name host:/path/to/area +## -or- +## name /path/to/area +[disks] +1 /tmp ADDED tests/runconfigs.config Index: tests/runconfigs.config ================================================================== --- /dev/null +++ tests/runconfigs.config @@ -0,0 +1,7 @@ +[/tmp/mrwellan/env/ubuntu/afs] +BOGOUS Bob + +[default/ubuntu/nfs] +CURRENT /blah + +[default] ADDED tests/supportfiles/ruby/librunscript.rb Index: tests/supportfiles/ruby/librunscript.rb ================================================================== --- /dev/null +++ tests/supportfiles/ruby/librunscript.rb @@ -0,0 +1,37 @@ +# This is the library of stuff for megatest + +def run_and_record(stepname, cmd, checks) + system "megatest -step #{stepname} :state start :status n/a" + system cmd + exitcode=$? + if exitcode==0 + exitcode='pass' + else + exitcode='fail' + end + system "megatest -step #{stepname} :state end :status #{exitcode}" +end + +def record_step(stepname,state,status) + system "megatest -step #{stepname} :state #{state} :status #{status}" +end + +def test_status(state,status) + system "megatest -test-status :state #{state} :status #{status}" +end + + +# WARNING: This example is deprecated. Don't use the -test-status command +# unless you know for sure what you are doing. +def file_size_checker(stepname,filename,minsize,maxsize) + fsize=File.size(filename) + if fsize > maxsize or fsize < minsize + system "megatest -test-status :state COMPLETED :status fail" + else + system "megatest -test-status :state COMPLETED :status pass" + end +end + + +def wait_for_step(testname,stepname) +end ADDED tests/test.config Index: tests/test.config ================================================================== --- /dev/null +++ tests/test.config @@ -0,0 +1,21 @@ +[section1] +1 ./blah + +[section2] + +# A comment + +[disks] +1 ./ + +[validvalues] +state start end aborted +status pass fail n/a + +[include a file that doesn't exist] + + +blah nada + +# now inlcude a file tha tdoes exist +[include megatest.config] ADDED tests/tests.scm Index: tests/tests.scm ================================================================== --- /dev/null +++ tests/tests.scm @@ -0,0 +1,85 @@ +(use test) +;; (require-library args) + +(include "../common.scm") +(include "../keys.scm") +(include "../db.scm") +(include "../configf.scm") +(include "../process.scm") +(include "../launch.scm") +(include "../items.scm") +(include "../runs.scm") + +(define conffile #f) +(test "Read a config" #t (hash-table? (read-config "test.config"))) +(test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config"))) + +(set! conffile (read-config "test.config")) +(test "Get available diskspace" #t (number? (get-df "./"))) +(test "Get best dir" #t (let ((bestdir (get-best-disk conffile))) + (or (equal? "./" bestdir) + (equal? "/tmp" bestdir)))) + +;; db +(define row (vector "a" "b" "c" "blah")) +(define header (list "col1" "col2" "col3" "col4")) +(test "Get row by header" "blah" (db-get-value-by-header row header "col4")) + +;; (define *toppath* "tests") +(define *db* #f) +(test "setup for run" #t (begin (setup-for-run) + (string? (getenv "MT_RUN_AREA_HOME")))) +(test "open-db" #t (begin + (set! *db* (open-db)) + (if *db* #t #f))) + +(test "get cpu load" #t (number? (get-cpu-load))) +(test "get uname" #t (string? (get-uname))) + +(test "get validvalues as list" (list "start" "end" "completed") + (string-split (config-lookup *configdat* "validvalues" "state"))) + +(for-each (lambda (item) + (test (conc "get valid items (" item ")") + item (check-valid-items "state" item))) + (list "start" "end" "completed")) + +(for-each (lambda (item) + (test (conc "get valid items (" item ")") + item (check-valid-items "status" item))) + (list "pass" "fail" "n/a")) + +(test "write env files" "nada.csh" (begin + (save-environment-as-files "nada") + (and (file-exists? "nada.sh") + (file-exists? "nada.csh")))) + +(test "get all legal tests" (list "runfirst" "sqlitespeed") (sort (get-all-legal-tests) string<=?)) + +(test "register-test, test info" "NOT_STARTED" + (begin + (register-test *db* 1 "nada" "") + (test:get-state (runs:get-test-info *db* 1 "nada" "")))) + +(test "get-keys" "sysname" (key:get-fieldname (car (sort (db-get-keys *db*)(lambda (a b)(string>=? (vector-ref a 0)(vector-ref b 0))))))) + +(define remargs (args:get-args + '("bar" "foo" ":runname" "bob" ":sysname" "ubuntu" ":fsname" "nfs" ":datapath" "blah/foo" "nada") + (list ":runname" ":state" ":status") + (list "-h") + args:arg-hash + 0)) + +(test "register-run" #t (number? (register-run *db* (db-get-keys *db*)))) + +;;(test "update-test-info" #t (test-update-meta-info *db* 1 "nada" +(setenv "BLAHFOO" "1234") +(unsetenv "NADAFOO") +(test "env temp overrides" "xyz" (let ((prevvals (alist->env-vars '(("BLAHFOO" 4321)("NADAFOO" xyz)))) + (result (get-environment-variable "NADAFOO"))) + (alist->env-vars prevvals) + result)) + +(test "env restored" "1234" (get-environment-variable "BLAHFOO")) + + ADDED tests/tests/runfirst/main.sh Index: tests/tests/runfirst/main.sh ================================================================== --- /dev/null +++ tests/tests/runfirst/main.sh @@ -0,0 +1,7 @@ +#!/bin/bash + +megatest -step wasting_time :state start :status n/a +sleep 20 +megatest -step wasting_time :state end :status $? + +megatest -test-status :state COMPLETED :status PASS -setlog thelogfile.log ADDED tests/tests/runfirst/testconfig Index: tests/tests/runfirst/testconfig ================================================================== --- /dev/null +++ tests/tests/runfirst/testconfig @@ -0,0 +1,16 @@ +[setup] +runscript main.sh + +[requirements] +diskspace 1M +memory 1G + +[pre-launch-env-vars] +# These are set before the test is launched on the originating +# host. This can be used to control remote launch tools, e.g. to +# to choose the target host, select the launch tool etc. +SPECIAL_ENV_VAR override with everything after the first space. + +[items] +SEASON summer winter fall spring + ADDED tests/tests/sqlitespeed/runscript.rb Index: tests/tests/sqlitespeed/runscript.rb ================================================================== --- /dev/null +++ tests/tests/sqlitespeed/runscript.rb @@ -0,0 +1,30 @@ +#! /usr/bin/ruby + +require "#{ENV['MT_RUN_AREA_HOME']}/supportfiles/ruby/librunscript.rb" + +# run_record(stepname, cmd) - will record in db if exit code of script was zero or not +run_and_record('create db',"sqlite3 testing.db << EOF\ncreate table if not exists blah(id INTEGER PRIMARY KEY,name TEXT);\n.q\nEOF","") + +# file_size_checker(stepname, filename, minsize, maxsize) - negative means ignore +# file_size_checker('create db','testing.db',100,-1) + +num_records=rand(60) # 0000 +record_step("add #{num_records}","start","n/a") +status=false +(0..num_records).each do |i| + randstring="a;lskdfja;sdfj;alsdfj;aslfdj;alsfja;lsfdj;alsfja;lsjfd;lasfjl;asdfja;slfj;alsjf;asljf;alsjf;lasdjf;lasjf;lasjf;alsjf;lashflkashflkerhflkdsvnlasldhlfaldf" + # status=system "sqlite3 testing.db \"insert into blah (name) values ('#{randstring}');\"" + system "megatest -step testing :state wrote_junk :status #{num_records}" + sleep(1) + puts "i=#{i}" +end +if status==0 + status='pass' +else + status='fail' +end +record_step("add #{num_records}","end",status) + + + + ADDED tests/tests/sqlitespeed/testconfig Index: tests/tests/sqlitespeed/testconfig ================================================================== --- /dev/null +++ tests/tests/sqlitespeed/testconfig @@ -0,0 +1,14 @@ +[setup] +runscript runscript.rb + +[requirements] +diskspace 1M +memory 1G +waiton runfirst + +[env-override] +# Test specific environment overrides go here +SPECIAL_ENV_VAR override with everything after the space. + +[items] +MANYITEMS a b c d e f g h i j k l m ADDED utils/nbfake Index: utils/nbfake ================================================================== --- /dev/null +++ utils/nbfake @@ -0,0 +1,12 @@ +#!/bin/bash + +# ssh localhost "nohup $* > nbfake.log 2> nbfake.err < /dev/null" + +if [[ $TARGETHOST == "" ]]; then + TARGETHOST=localhost +fi + +# Can't always trust $PWD +CURRWD=`pwd` + +ssh -n -f $TARGETHOST "sh -c \"cd $CURRWD; nohup $* > NBFAKE-`date +%GWW%V.%u_%T` 2>&1 &\"" ADDED utils/runner Index: utils/runner ================================================================== --- /dev/null +++ utils/runner @@ -0,0 +1,27 @@ +#!/usr/bin/perl -w + +$starthr=`date +%k`; +$hrsper = 1; +$nexthr=$starthr + $hrsper; + +$ltr='a'; + +while (1) { + $runname = `date +%GWW%V.%u`; + chomp $runname; + $runname = $runname . $ltr; + $cmd = "megatest -runall :datapath testing :fsname local :sysname ubuntu :runname $runname"; + print "Running $cmd\n"; + system $cmd; + $currhr = `date +%k`; + if ($currhr > $nexthr) { + $ltr = chr(ord($ltr)+1); + $nexthr=$nexthr + $hrsper; + } + if ($nexthr > 23) { + $nexthr = 0; + } + sleep 10; +} + +