Overview
| SHA1 Hash: | ae6dbecf17ce30a67630815a5a8d8b27519c8cb2 |
|---|---|
| Date: | 2011-05-01 23:05:22 |
| User: | matt |
| Comment: | Importing 1.0.1 version of megatest, (nb// work in progress, please wait for next release) |
| Timelines: | family | ancestors | descendants | both | trunk |
| Downloads: | Tarball | ZIP archive |
| Other Links: | files | file ages | manifest |
Tags And Properties
- branch=trunk inherited from [d673a9367e]
- sym-trunk inherited from [d673a9367e]
Changes
Added COPYING version [7d7e3bd4448ca545]
> 1 GNU GENERAL PUBLIC LICENSE > 2 Version 2, June 1991 > 3 > 4 Copyright (C) 1989, 1991 Free Software Foundation, Inc. > 5 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA > 6 Everyone is permitted to copy and distribute verbatim copies > 7 of this license document, but changing it is not allowed. > 8 > 9 Preamble > 10 > 11 The licenses for most software are designed to take away your > 12 freedom to share and change it. By contrast, the GNU General Public > 13 License is intended to guarantee your freedom to share and change free > 14 software--to make sure the software is free for all its users. This > 15 General Public License applies to most of the Free Software > 16 Foundation's software and to any other program whose authors commit to > 17 using it. (Some other Free Software Foundation software is covered by > 18 the GNU Library General Public License instead.) You can apply it to > 19 your programs, too. > 20 > 21 When we speak of free software, we are referring to freedom, not > 22 price. Our General Public Licenses are designed to make sure that you > 23 have the freedom to distribute copies of free software (and charge for > 24 this service if you wish), that you receive source code or can get it > 25 if you want it, that you can change the software or use pieces of it > 26 in new free programs; and that you know you can do these things. > 27 > 28 To protect your rights, we need to make restrictions that forbid > 29 anyone to deny you these rights or to ask you to surrender the rights. > 30 These restrictions translate to certain responsibilities for you if you > 31 distribute copies of the software, or if you modify it. > 32 > 33 For example, if you distribute copies of such a program, whether > 34 gratis or for a fee, you must give the recipients all the rights that > 35 you have. You must make sure that they, too, receive or can get the > 36 source code. And you must show them these terms so they know their > 37 rights. > 38 > 39 We protect your rights with two steps: (1) copyright the software, and > 40 (2) offer you this license which gives you legal permission to copy, > 41 distribute and/or modify the software. > 42 > 43 Also, for each author's protection and ours, we want to make certain > 44 that everyone understands that there is no warranty for this free > 45 software. If the software is modified by someone else and passed on, we > 46 want its recipients to know that what they have is not the original, so > 47 that any problems introduced by others will not reflect on the original > 48 authors' reputations. > 49 > 50 Finally, any free program is threatened constantly by software > 51 patents. We wish to avoid the danger that redistributors of a free > 52 program will individually obtain patent licenses, in effect making the > 53 program proprietary. To prevent this, we have made it clear that any > 54 patent must be licensed for everyone's free use or not licensed at all. > 55 > 56 The precise terms and conditions for copying, distribution and > 57 modification follow. > 58 > 59 GNU GENERAL PUBLIC LICENSE > 60 TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION > 61 > 62 0. This License applies to any program or other work which contains > 63 a notice placed by the copyright holder saying it may be distributed > 64 under the terms of this General Public License. The "Program", below, > 65 refers to any such program or work, and a "work based on the Program" > 66 means either the Program or any derivative work under copyright law: > 67 that is to say, a work containing the Program or a portion of it, > 68 either verbatim or with modifications and/or translated into another > 69 language. (Hereinafter, translation is included without limitation in > 70 the term "modification".) Each licensee is addressed as "you". > 71 > 72 Activities other than copying, distribution and modification are not > 73 covered by this License; they are outside its scope. The act of > 74 running the Program is not restricted, and the output from the Program > 75 is covered only if its contents constitute a work based on the > 76 Program (independent of having been made by running the Program). > 77 Whether that is true depends on what the Program does. > 78 > 79 1. You may copy and distribute verbatim copies of the Program's > 80 source code as you receive it, in any medium, provided that you > 81 conspicuously and appropriately publish on each copy an appropriate > 82 copyright notice and disclaimer of warranty; keep intact all the > 83 notices that refer to this License and to the absence of any warranty; > 84 and give any other recipients of the Program a copy of this License > 85 along with the Program. > 86 > 87 You may charge a fee for the physical act of transferring a copy, and > 88 you may at your option offer warranty protection in exchange for a fee. > 89 > 90 2. You may modify your copy or copies of the Program or any portion > 91 of it, thus forming a work based on the Program, and copy and > 92 distribute such modifications or work under the terms of Section 1 > 93 above, provided that you also meet all of these conditions: > 94 > 95 a) You must cause the modified files to carry prominent notices > 96 stating that you changed the files and the date of any change. > 97 > 98 b) You must cause any work that you distribute or publish, that in > 99 whole or in part contains or is derived from the Program or any > 100 part thereof, to be licensed as a whole at no charge to all third > 101 parties under the terms of this License. > 102 > 103 c) If the modified program normally reads commands interactively > 104 when run, you must cause it, when started running for such > 105 interactive use in the most ordinary way, to print or display an > 106 announcement including an appropriate copyright notice and a > 107 notice that there is no warranty (or else, saying that you provide > 108 a warranty) and that users may redistribute the program under > 109 these conditions, and telling the user how to view a copy of this > 110 License. (Exception: if the Program itself is interactive but > 111 does not normally print such an announcement, your work based on > 112 the Program is not required to print an announcement.) > 113 > 114 These requirements apply to the modified work as a whole. If > 115 identifiable sections of that work are not derived from the Program, > 116 and can be reasonably considered independent and separate works in > 117 themselves, then this License, and its terms, do not apply to those > 118 sections when you distribute them as separate works. But when you > 119 distribute the same sections as part of a whole which is a work based > 120 on the Program, the distribution of the whole must be on the terms of > 121 this License, whose permissions for other licensees extend to the > 122 entire whole, and thus to each and every part regardless of who wrote it. > 123 > 124 Thus, it is not the intent of this section to claim rights or contest > 125 your rights to work written entirely by you; rather, the intent is to > 126 exercise the right to control the distribution of derivative or > 127 collective works based on the Program. > 128 > 129 In addition, mere aggregation of another work not based on the Program > 130 with the Program (or with a work based on the Program) on a volume of > 131 a storage or distribution medium does not bring the other work under > 132 the scope of this License. > 133 > 134 3. You may copy and distribute the Program (or a work based on it, > 135 under Section 2) in object code or executable form under the terms of > 136 Sections 1 and 2 above provided that you also do one of the following: > 137 > 138 a) Accompany it with the complete corresponding machine-readable > 139 source code, which must be distributed under the terms of Sections > 140 1 and 2 above on a medium customarily used for software interchange; or, > 141 > 142 b) Accompany it with a written offer, valid for at least three > 143 years, to give any third party, for a charge no more than your > 144 cost of physically performing source distribution, a complete > 145 machine-readable copy of the corresponding source code, to be > 146 distributed under the terms of Sections 1 and 2 above on a medium > 147 customarily used for software interchange; or, > 148 > 149 c) Accompany it with the information you received as to the offer > 150 to distribute corresponding source code. (This alternative is > 151 allowed only for noncommercial distribution and only if you > 152 received the program in object code or executable form with such > 153 an offer, in accord with Subsection b above.) > 154 > 155 The source code for a work means the preferred form of the work for > 156 making modifications to it. For an executable work, complete source > 157 code means all the source code for all modules it contains, plus any > 158 associated interface definition files, plus the scripts used to > 159 control compilation and installation of the executable. However, as a > 160 special exception, the source code distributed need not include > 161 anything that is normally distributed (in either source or binary > 162 form) with the major components (compiler, kernel, and so on) of the > 163 operating system on which the executable runs, unless that component > 164 itself accompanies the executable. > 165 > 166 If distribution of executable or object code is made by offering > 167 access to copy from a designated place, then offering equivalent > 168 access to copy the source code from the same place counts as > 169 distribution of the source code, even though third parties are not > 170 compelled to copy the source along with the object code. > 171 > 172 4. You may not copy, modify, sublicense, or distribute the Program > 173 except as expressly provided under this License. Any attempt > 174 otherwise to copy, modify, sublicense or distribute the Program is > 175 void, and will automatically terminate your rights under this License. > 176 However, parties who have received copies, or rights, from you under > 177 this License will not have their licenses terminated so long as such > 178 parties remain in full compliance. > 179 > 180 5. You are not required to accept this License, since you have not > 181 signed it. However, nothing else grants you permission to modify or > 182 distribute the Program or its derivative works. These actions are > 183 prohibited by law if you do not accept this License. Therefore, by > 184 modifying or distributing the Program (or any work based on the > 185 Program), you indicate your acceptance of this License to do so, and > 186 all its terms and conditions for copying, distributing or modifying > 187 the Program or works based on it. > 188 > 189 6. Each time you redistribute the Program (or any work based on the > 190 Program), the recipient automatically receives a license from the > 191 original licensor to copy, distribute or modify the Program subject to > 192 these terms and conditions. You may not impose any further > 193 restrictions on the recipients' exercise of the rights granted herein. > 194 You are not responsible for enforcing compliance by third parties to > 195 this License. > 196 > 197 7. If, as a consequence of a court judgment or allegation of patent > 198 infringement or for any other reason (not limited to patent issues), > 199 conditions are imposed on you (whether by court order, agreement or > 200 otherwise) that contradict the conditions of this License, they do not > 201 excuse you from the conditions of this License. If you cannot > 202 distribute so as to satisfy simultaneously your obligations under this > 203 License and any other pertinent obligations, then as a consequence you > 204 may not distribute the Program at all. For example, if a patent > 205 license would not permit royalty-free redistribution of the Program by > 206 all those who receive copies directly or indirectly through you, then > 207 the only way you could satisfy both it and this License would be to > 208 refrain entirely from distribution of the Program. > 209 > 210 If any portion of this section is held invalid or unenforceable under > 211 any particular circumstance, the balance of the section is intended to > 212 apply and the section as a whole is intended to apply in other > 213 circumstances. > 214 > 215 It is not the purpose of this section to induce you to infringe any > 216 patents or other property right claims or to contest validity of any > 217 such claims; this section has the sole purpose of protecting the > 218 integrity of the free software distribution system, which is > 219 implemented by public license practices. Many people have made > 220 generous contributions to the wide range of software distributed > 221 through that system in reliance on consistent application of that > 222 system; it is up to the author/donor to decide if he or she is willing > 223 to distribute software through any other system and a licensee cannot > 224 impose that choice. > 225 > 226 This section is intended to make thoroughly clear what is believed to > 227 be a consequence of the rest of this License. > 228 > 229 8. If the distribution and/or use of the Program is restricted in > 230 certain countries either by patents or by copyrighted interfaces, the > 231 original copyright holder who places the Program under this License > 232 may add an explicit geographical distribution limitation excluding > 233 those countries, so that distribution is permitted only in or among > 234 countries not thus excluded. In such case, this License incorporates > 235 the limitation as if written in the body of this License. > 236 > 237 9. The Free Software Foundation may publish revised and/or new versions > 238 of the General Public License from time to time. Such new versions will > 239 be similar in spirit to the present version, but may differ in detail to > 240 address new problems or concerns. > 241 > 242 Each version is given a distinguishing version number. If the Program > 243 specifies a version number of this License which applies to it and "any > 244 later version", you have the option of following the terms and conditions > 245 either of that version or of any later version published by the Free > 246 Software Foundation. If the Program does not specify a version number of > 247 this License, you may choose any version ever published by the Free Software > 248 Foundation. > 249 > 250 10. If you wish to incorporate parts of the Program into other free > 251 programs whose distribution conditions are different, write to the author > 252 to ask for permission. For software which is copyrighted by the Free > 253 Software Foundation, write to the Free Software Foundation; we sometimes > 254 make exceptions for this. Our decision will be guided by the two goals > 255 of preserving the free status of all derivatives of our free software and > 256 of promoting the sharing and reuse of software generally. > 257 > 258 NO WARRANTY > 259 > 260 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY > 261 FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN > 262 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES > 263 PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED > 264 OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF > 265 MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS > 266 TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE > 267 PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, > 268 REPAIR OR CORRECTION. > 269 > 270 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING > 271 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR > 272 REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, > 273 INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING > 274 OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED > 275 TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY > 276 YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER > 277 PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE > 278 POSSIBILITY OF SUCH DAMAGES. > 279 > 280 END OF TERMS AND CONDITIONS > 281 > 282 How to Apply These Terms to Your New Programs > 283 > 284 If you develop a new program, and you want it to be of the greatest > 285 possible use to the public, the best way to achieve this is to make it > 286 free software which everyone can redistribute and change under these terms. > 287 > 288 To do so, attach the following notices to the program. It is safest > 289 to attach them to the start of each source file to most effectively > 290 convey the exclusion of warranty; and each file should have at least > 291 the "copyright" line and a pointer to where the full notice is found. > 292 > 293 <one line to give the program's name and a brief idea of what it does.> > 294 Copyright (C) <year> <name of author> > 295 > 296 This program is free software; you can redistribute it and/or modify > 297 it under the terms of the GNU General Public License as published by > 298 the Free Software Foundation; either version 2 of the License, or > 299 (at your option) any later version. > 300 > 301 This program is distributed in the hope that it will be useful, > 302 but WITHOUT ANY WARRANTY; without even the implied warranty of > 303 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the > 304 GNU General Public License for more details. > 305 > 306 You should have received a copy of the GNU General Public License > 307 along with this program; if not, write to the Free Software > 308 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA > 309 > 310 > 311 Also add information on how to contact you by electronic and paper mail. > 312 > 313 If the program is interactive, make it output a short notice like this > 314 when it starts in an interactive mode: > 315 > 316 Gnomovision version 69, Copyright (C) year name of author > 317 Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. > 318 This is free software, and you are welcome to redistribute it > 319 under certain conditions; type `show c' for details. > 320 > 321 The hypothetical commands `show w' and `show c' should show the appropriate > 322 parts of the General Public License. Of course, the commands you use may > 323 be called something other than `show w' and `show c'; they could even be > 324 mouse-clicks or menu items--whatever suits your program. > 325 > 326 You should also get your employer (if you work as a programmer) or your > 327 school, if any, to sign a "copyright disclaimer" for the program, if > 328 necessary. Here is a sample; alter the names: > 329 > 330 Yoyodyne, Inc., hereby disclaims all copyright interest in the program > 331 `Gnomovision' (which makes passes at compilers) written by James Hacker. > 332 > 333 <signature of Ty Coon>, 1 April 1989 > 334 Ty Coon, President of Vice > 335 > 336 This General Public License does not permit incorporating your program into > 337 proprietary programs. If your program is a subroutine library, you may > 338 consider it more useful to permit linking proprietary applications with the > 339 library. If this is what you want to do, use the GNU Library General > 340 Public License instead of this License. > 341 > 342 > 343 GNU Free Documentation License > 344 ****************************** > 345 > 346 Version 1.1, March 2000 > 347 Copyright (C) 2000 Free Software Foundation, Inc. > 348 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA > 349 > 350 Everyone is permitted to copy and distribute verbatim copies > 351 of this license document, but changing it is not allowed. > 352 > 353 0. PREAMBLE > 354 > 355 The purpose of this License is to make a manual, textbook, or other > 356 written document "free" in the sense of freedom: to assure everyone > 357 the effective freedom to copy and redistribute it, with or without > 358 modifying it, either commercially or noncommercially. Secondarily, > 359 this License preserves for the author and publisher a way to get > 360 credit for their work, while not being considered responsible for > 361 modifications made by others. > 362 > 363 This License is a kind of "copyleft", which means that derivative > 364 works of the document must themselves be free in the same sense. > 365 It complements the GNU General Public License, which is a copyleft > 366 license designed for free software. > 367 > 368 We have designed this License in order to use it for manuals for > 369 free software, because free software needs free documentation: a > 370 free program should come with manuals providing the same freedoms > 371 that the software does. But this License is not limited to > 372 software manuals; it can be used for any textual work, regardless > 373 of subject matter or whether it is published as a printed book. > 374 We recommend this License principally for works whose purpose is > 375 instruction or reference. > 376 > 377 1. APPLICABILITY AND DEFINITIONS > 378 > 379 This License applies to any manual or other work that contains a > 380 notice placed by the copyright holder saying it can be distributed > 381 under the terms of this License. The "Document", below, refers to > 382 any such manual or work. Any member of the public is a licensee, > 383 and is addressed as "you". > 384 > 385 A "Modified Version" of the Document means any work containing the > 386 Document or a portion of it, either copied verbatim, or with > 387 modifications and/or translated into another language. > 388 > 389 A "Secondary Section" is a named appendix or a front-matter > 390 section of the Document that deals exclusively with the > 391 relationship of the publishers or authors of the Document to the > 392 Document's overall subject (or to related matters) and contains > 393 nothing that could fall directly within that overall subject. > 394 (For example, if the Document is in part a textbook of > 395 mathematics, a Secondary Section may not explain any mathematics.) > 396 The relationship could be a matter of historical connection with > 397 the subject or with related matters, or of legal, commercial, > 398 philosophical, ethical or political position regarding them. > 399 > 400 The "Invariant Sections" are certain Secondary Sections whose > 401 titles are designated, as being those of Invariant Sections, in > 402 the notice that says that the Document is released under this > 403 License. > 404 > 405 The "Cover Texts" are certain short passages of text that are > 406 listed, as Front-Cover Texts or Back-Cover Texts, in the notice > 407 that says that the Document is released under this License. > 408 > 409 A "Transparent" copy of the Document means a machine-readable copy, > 410 represented in a format whose specification is available to the > 411 general public, whose contents can be viewed and edited directly > 412 and straightforwardly with generic text editors or (for images > 413 composed of pixels) generic paint programs or (for drawings) some > 414 widely available drawing editor, and that is suitable for input to > 415 text formatters or for automatic translation to a variety of > 416 formats suitable for input to text formatters. A copy made in an > 417 otherwise Transparent file format whose markup has been designed > 418 to thwart or discourage subsequent modification by readers is not > 419 Transparent. A copy that is not "Transparent" is called "Opaque". > 420 > 421 Examples of suitable formats for Transparent copies include plain > 422 ASCII without markup, Texinfo input format, LaTeX input format, > 423 SGML or XML using a publicly available DTD, and > 424 standard-conforming simple HTML designed for human modification. > 425 Opaque formats include PostScript, PDF, proprietary formats that > 426 can be read and edited only by proprietary word processors, SGML > 427 or XML for which the DTD and/or processing tools are not generally > 428 available, and the machine-generated HTML produced by some word > 429 processors for output purposes only. > 430 > 431 The "Title Page" means, for a printed book, the title page itself, > 432 plus such following pages as are needed to hold, legibly, the > 433 material this License requires to appear in the title page. For > 434 works in formats which do not have any title page as such, "Title > 435 Page" means the text near the most prominent appearance of the > 436 work's title, preceding the beginning of the body of the text. > 437 > 438 2. VERBATIM COPYING > 439 > 440 You may copy and distribute the Document in any medium, either > 441 commercially or noncommercially, provided that this License, the > 442 copyright notices, and the license notice saying this License > 443 applies to the Document are reproduced in all copies, and that you > 444 add no other conditions whatsoever to those of this License. You > 445 may not use technical measures to obstruct or control the reading > 446 or further copying of the copies you make or distribute. However, > 447 you may accept compensation in exchange for copies. If you > 448 distribute a large enough number of copies you must also follow > 449 the conditions in section 3. > 450 > 451 You may also lend copies, under the same conditions stated above, > 452 and you may publicly display copies. > 453 > 454 3. COPYING IN QUANTITY > 455 > 456 If you publish printed copies of the Document numbering more than > 457 100, and the Document's license notice requires Cover Texts, you > 458 must enclose the copies in covers that carry, clearly and legibly, > 459 all these Cover Texts: Front-Cover Texts on the front cover, and > 460 Back-Cover Texts on the back cover. Both covers must also clearly > 461 and legibly identify you as the publisher of these copies. The > 462 front cover must present the full title with all words of the > 463 title equally prominent and visible. You may add other material > 464 on the covers in addition. Copying with changes limited to the > 465 covers, as long as they preserve the title of the Document and > 466 satisfy these conditions, can be treated as verbatim copying in > 467 other respects. > 468 > 469 If the required texts for either cover are too voluminous to fit > 470 legibly, you should put the first ones listed (as many as fit > 471 reasonably) on the actual cover, and continue the rest onto > 472 adjacent pages. > 473 > 474 If you publish or distribute Opaque copies of the Document > 475 numbering more than 100, you must either include a > 476 machine-readable Transparent copy along with each Opaque copy, or > 477 state in or with each Opaque copy a publicly-accessible > 478 computer-network location containing a complete Transparent copy > 479 of the Document, free of added material, which the general > 480 network-using public has access to download anonymously at no > 481 charge using public-standard network protocols. If you use the > 482 latter option, you must take reasonably prudent steps, when you > 483 begin distribution of Opaque copies in quantity, to ensure that > 484 this Transparent copy will remain thus accessible at the stated > 485 location until at least one year after the last time you > 486 distribute an Opaque copy (directly or through your agents or > 487 retailers) of that edition to the public. > 488 > 489 It is requested, but not required, that you contact the authors of > 490 the Document well before redistributing any large number of > 491 copies, to give them a chance to provide you with an updated > 492 version of the Document. > 493 > 494 4. MODIFICATIONS > 495 > 496 You may copy and distribute a Modified Version of the Document > 497 under the conditions of sections 2 and 3 above, provided that you > 498 release the Modified Version under precisely this License, with > 499 the Modified Version filling the role of the Document, thus > 500 licensing distribution and modification of the Modified Version to > 501 whoever possesses a copy of it. In addition, you must do these > 502 things in the Modified Version: > 503 > 504 A. Use in the Title Page (and on the covers, if any) a title > 505 distinct from that of the Document, and from those of > 506 previous versions (which should, if there were any, be listed > 507 in the History section of the Document). You may use the > 508 same title as a previous version if the original publisher of > 509 that version gives permission. > 510 > 511 B. List on the Title Page, as authors, one or more persons or > 512 entities responsible for authorship of the modifications in > 513 the Modified Version, together with at least five of the > 514 principal authors of the Document (all of its principal > 515 authors, if it has less than five). > 516 > 517 C. State on the Title page the name of the publisher of the > 518 Modified Version, as the publisher. > 519 > 520 D. Preserve all the copyright notices of the Document. > 521 > 522 E. Add an appropriate copyright notice for your modifications > 523 adjacent to the other copyright notices. > 524 > 525 F. Include, immediately after the copyright notices, a license > 526 notice giving the public permission to use the Modified > 527 Version under the terms of this License, in the form shown in > 528 the Addendum below. > 529 > 530 G. Preserve in that license notice the full lists of Invariant > 531 Sections and required Cover Texts given in the Document's > 532 license notice. > 533 > 534 H. Include an unaltered copy of this License. > 535 > 536 I. Preserve the section entitled "History", and its title, and > 537 add to it an item stating at least the title, year, new > 538 authors, and publisher of the Modified Version as given on > 539 the Title Page. If there is no section entitled "History" in > 540 the Document, create one stating the title, year, authors, > 541 and publisher of the Document as given on its Title Page, > 542 then add an item describing the Modified Version as stated in > 543 the previous sentence. > 544 > 545 J. Preserve the network location, if any, given in the Document > 546 for public access to a Transparent copy of the Document, and > 547 likewise the network locations given in the Document for > 548 previous versions it was based on. These may be placed in > 549 the "History" section. You may omit a network location for a > 550 work that was published at least four years before the > 551 Document itself, or if the original publisher of the version > 552 it refers to gives permission. > 553 > 554 K. In any section entitled "Acknowledgments" or "Dedications", > 555 preserve the section's title, and preserve in the section all > 556 the substance and tone of each of the contributor > 557 acknowledgments and/or dedications given therein. > 558 > 559 L. Preserve all the Invariant Sections of the Document, > 560 unaltered in their text and in their titles. Section numbers > 561 or the equivalent are not considered part of the section > 562 titles. > 563 > 564 M. Delete any section entitled "Endorsements". Such a section > 565 may not be included in the Modified Version. > 566 > 567 N. Do not retitle any existing section as "Endorsements" or to > 568 conflict in title with any Invariant Section. > 569 > 570 If the Modified Version includes new front-matter sections or > 571 appendices that qualify as Secondary Sections and contain no > 572 material copied from the Document, you may at your option > 573 designate some or all of these sections as invariant. To do this, > 574 add their titles to the list of Invariant Sections in the Modified > 575 Version's license notice. These titles must be distinct from any > 576 other section titles. > 577 > 578 You may add a section entitled "Endorsements", provided it contains > 579 nothing but endorsements of your Modified Version by various > 580 parties--for example, statements of peer review or that the text > 581 has been approved by an organization as the authoritative > 582 definition of a standard. > 583 > 584 You may add a passage of up to five words as a Front-Cover Text, > 585 and a passage of up to 25 words as a Back-Cover Text, to the end > 586 of the list of Cover Texts in the Modified Version. Only one > 587 passage of Front-Cover Text and one of Back-Cover Text may be > 588 added by (or through arrangements made by) any one entity. If the > 589 Document already includes a cover text for the same cover, > 590 previously added by you or by arrangement made by the same entity > 591 you are acting on behalf of, you may not add another; but you may > 592 replace the old one, on explicit permission from the previous > 593 publisher that added the old one. > 594 > 595 The author(s) and publisher(s) of the Document do not by this > 596 License give permission to use their names for publicity for or to > 597 assert or imply endorsement of any Modified Version. > 598 > 599 5. COMBINING DOCUMENTS > 600 > 601 You may combine the Document with other documents released under > 602 this License, under the terms defined in section 4 above for > 603 modified versions, provided that you include in the combination > 604 all of the Invariant Sections of all of the original documents, > 605 unmodified, and list them all as Invariant Sections of your > 606 combined work in its license notice. > 607 > 608 The combined work need only contain one copy of this License, and > 609 multiple identical Invariant Sections may be replaced with a single > 610 copy. If there are multiple Invariant Sections with the same name > 611 but different contents, make the title of each such section unique > 612 by adding at the end of it, in parentheses, the name of the > 613 original author or publisher of that section if known, or else a > 614 unique number. Make the same adjustment to the section titles in > 615 the list of Invariant Sections in the license notice of the > 616 combined work. > 617 > 618 In the combination, you must combine any sections entitled > 619 "History" in the various original documents, forming one section > 620 entitled "History"; likewise combine any sections entitled > 621 "Acknowledgments", and any sections entitled "Dedications". You > 622 must delete all sections entitled "Endorsements." > 623 > 624 6. COLLECTIONS OF DOCUMENTS > 625 > 626 You may make a collection consisting of the Document and other > 627 documents released under this License, and replace the individual > 628 copies of this License in the various documents with a single copy > 629 that is included in the collection, provided that you follow the > 630 rules of this License for verbatim copying of each of the > 631 documents in all other respects. > 632 > 633 You may extract a single document from such a collection, and > 634 distribute it individually under this License, provided you insert > 635 a copy of this License into the extracted document, and follow > 636 this License in all other respects regarding verbatim copying of > 637 that document. > 638 > 639 7. AGGREGATION WITH INDEPENDENT WORKS > 640 > 641 A compilation of the Document or its derivatives with other > 642 separate and independent documents or works, in or on a volume of > 643 a storage or distribution medium, does not as a whole count as a > 644 Modified Version of the Document, provided no compilation > 645 copyright is claimed for the compilation. Such a compilation is > 646 called an "aggregate", and this License does not apply to the > 647 other self-contained works thus compiled with the Document, on > 648 account of their being thus compiled, if they are not themselves > 649 derivative works of the Document. > 650 > 651 If the Cover Text requirement of section 3 is applicable to these > 652 copies of the Document, then if the Document is less than one > 653 quarter of the entire aggregate, the Document's Cover Texts may be > 654 placed on covers that surround only the Document within the > 655 aggregate. Otherwise they must appear on covers around the whole > 656 aggregate. > 657 > 658 8. TRANSLATION > 659 > 660 Translation is considered a kind of modification, so you may > 661 distribute translations of the Document under the terms of section > 662 4. Replacing Invariant Sections with translations requires special > 663 permission from their copyright holders, but you may include > 664 translations of some or all Invariant Sections in addition to the > 665 original versions of these Invariant Sections. You may include a > 666 translation of this License provided that you also include the > 667 original English version of this License. In case of a > 668 disagreement between the translation and the original English > 669 version of this License, the original English version will prevail. > 670 > 671 9. TERMINATION > 672 > 673 You may not copy, modify, sublicense, or distribute the Document > 674 except as expressly provided for under this License. Any other > 675 attempt to copy, modify, sublicense or distribute the Document is > 676 void, and will automatically terminate your rights under this > 677 License. However, parties who have received copies, or rights, > 678 from you under this License will not have their licenses > 679 terminated so long as such parties remain in full compliance. > 680 > 681 10. FUTURE REVISIONS OF THIS LICENSE > 682 > 683 The Free Software Foundation may publish new, revised versions of > 684 the GNU Free Documentation License from time to time. Such new > 685 versions will be similar in spirit to the present version, but may > 686 differ in detail to address new problems or concerns. See > 687 `http://www.gnu.org/copyleft/'. > 688 > 689 Each version of the License is given a distinguishing version > 690 number. If the Document specifies that a particular numbered > 691 version of this License "or any later version" applies to it, you > 692 have the option of following the terms and conditions either of > 693 that specified version or of any later version that has been > 694 published (not as a draft) by the Free Software Foundation. If > 695 the Document does not specify a version number of this License, > 696 you may choose any version ever published (not as a draft) by the > 697 Free Software Foundation. > 698 > 699 ADDENDUM: How to use this License for your documents > 700 ---------------------------------------------------- > 701 > 702 To use this License in a document you have written, include a copy of > 703 the License in the document and put the following copyright and license > 704 notices just after the title page: > 705 > 706 Copyright (C) YEAR YOUR NAME. > 707 Permission is granted to copy, distribute and/or modify this document > 708 under the terms of the GNU Free Documentation License, Version 1.1 > 709 or any later version published by the Free Software Foundation; > 710 with the Invariant Sections being LIST THEIR TITLES, with the > 711 Front-Cover Texts being LIST, and with the Back-Cover Texts being LIST. > 712 A copy of the license is included in the section entitled ``GNU > 713 Free Documentation License''. > 714 > 715 If you have no Invariant Sections, write "with no Invariant Sections" > 716 instead of saying which ones are invariant. If you have no Front-Cover > 717 Texts, write "no Front-Cover Texts" instead of "Front-Cover Texts being > 718 LIST"; likewise for Back-Cover Texts. > 719 > 720 If your document contains nontrivial examples of program code, we > 721 recommend releasing these examples in parallel under your choice of > 722 free software license, such as the GNU General Public License, to > 723 permit their use in free software. > 724
Added Makefile version [65424085b194acd7]
> 1 FILES=$(glob *.scm) > 2 > 3 megatest: common.scm configf.scm db.scm keys.scm launch.scm megatest.scm process > 4 csc megatest.scm > 5 > 6 dashboard: megatest > 7 csc dashboard.scm > 8 > 9 $(PREFIX)/bin/megatest : megatest > 10 @echo Installing to PREFIX=$(PREFIX), use ^C to cancel and change > 11 sleep 5 > 12 cp megatest $(PREFIX)/bin/megatest > 13 > 14 $(PREFIX)/bin/dashboard : dashboard > 15 cp dashboard $(PREFIX)/bin/dashboard > 16 > 17 install : $(PREFIX)/bin/megatest $(PREFIX)/bin/dashboard > 18 > 19 test: megatest tests/tests.scm > 20 cd tests;csi -I .. -b -n tests.scm > 21
Added NOTES version [f2e86c65732a1707]
> 1 1. All run control access to db is direct. > 2 2. All test machines must have megatest available > 3 3. Tests may or may not have file system access to the originating > 4 run area. rsync is used to pull the test area to the home host > 5 if and only if the originating area can not be seen via file > 6 system. NO LONGER TRUE. Rsync is used but file system must be visible. > 7 4. All db access is done via the home host. NOT IMPLEMENTED YET.
Added TODO version [fdd124b7a65e2985]
> 1 1. Run all tests > 2 2. create run areas, copy in conf and scripts DONE > 3 3. Add a host chooser for ssh to launch-tests > 4 4. Run creation timestamp not happening DONE > 5 5 . Check for test already in progress, give meaningful message DONE > 6 6. Debug xterm creation for test generation DONE > 7 7. Capture run info, host, load, freemem at test launch DONE > 8 8. Rename to testalot? Nah! I like Meg > 9 10. Run, test and step comment field > 10 11. At end of test scan all tests for this run, if all done > 11 update run status to COMPLETED NOT gonna happe > 12 12. state and status lists need to be regexes > 13 13. Test on Chicken 4. DONE > 14 14. Try making static executable > 15 15. Log processor script DONE
Added common.scm version [9278a878515b5a3a]
> 1 ;;====================================================================== > 2 ;; Copyright 2006-2011, Matthew Welland. > 3 ;; > 4 ;; This program is made available under the GNU GPL version 2.0 or > 5 ;; greater. See the accompanying file COPYING for details. > 6 ;; > 7 ;; This program is distributed WITHOUT ANY WARRANTY; without even the > 8 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR > 9 ;; PURPOSE. > 10 ;;====================================================================== > 11 > 12 (use sqlite3 srfi-1 posix regex-case base64 format) > 13 (require-extension sqlite3 regex posix) > 14 > 15 (import (prefix sqlite3 sqlite3:)) > 16 (import (prefix base64 base64:)) > 17 > 18 ;; (require-library margs) > 19 (include "margs.scm") > 20 > 21 (define getenv get-environment-variable) > 22 > 23 (define home (getenv "HOME")) > 24 (define user (getenv "USER")) > 25 > 26 (define *configinfo* #f) > 27 (define *configdat* #f) > 28 (define *toppath* #f) > 29 (define *already-seen-runconfig-info* #f) > 30 (define *waiting-queue* (make-hash-table)) > 31 > 32 (define-inline (get-with-default val default) > 33 (let ((val (args:get-arg val))) > 34 (if val val default))) > 35 > 36 (define-inline (assoc/default key lst . default) > 37 (let ((res (assoc key lst))) > 38 (if res (cadr res)(if (null? default) #f (car default))))) > 39 > 40 ;;====================================================================== > 41 ;; Misc utils > 42 ;;====================================================================== > 43 > 44 (define (get-df path) > 45 (let* ((df-results (cmd-run->list (conc "df " path))) > 46 (space-rx (regexp "([0-9]+)\\s+([0-9]+)%")) > 47 (freespc #f)) > 48 ;; (write df-results) > 49 (for-each (lambda (l) > 50 (let ((match (string-search space-rx l))) > 51 (if match > 52 (let ((newval (string->number (cadr match)))) > 53 (if (number? newval) > 54 (set! freespc newval)))))) > 55 (car df-results)) > 56 freespc)) > 57 > 58 (define (get-cpu-load) > 59 (let* ((load-res (cmd-run->list "uptime")) > 60 (load-rx (regexp "load average:\\s+(\\d+)")) > 61 (cpu-load #f)) > 62 (for-each (lambda (l) > 63 (let ((match (string-search load-rx l))) > 64 (if match > 65 (let ((newval (string->number (cadr match)))) > 66 (if (number? newval) > 67 (set! cpu-load newval)))))) > 68 (car load-res)) > 69 cpu-load)) > 70 > 71 (define (get-uname . params) > 72 (let* ((uname-res (cmd-run->list (conc "uname " (if (null? params) "-a" (car p > 73 (uname #f)) > 74 (if (null? (car uname-res)) > 75 "unknown" > 76 (caar uname-res)))) > 77 > 78 (define (save-environment-as-files fname) > 79 (let ((envvars (get-environment-variables)) > 80 (whitesp (regexp "[^a-zA-Z0-9_\\-:;,.\\/%]"))) > 81 (with-output-to-file (conc fname ".csh") > 82 (lambda () > 83 (for-each (lambda (key) > 84 (let* ((val (cdr key)) > 85 (sval (if (string-search whitesp val)(conc "'" val > 86 (print "setenv " (car key) " " sval))) > 87 envvars))) > 88 (with-output-to-file (conc fname ".sh") > 89 (lambda () > 90 (for-each (lambda (key) > 91 (let* ((val (cdr key)) > 92 (sval (if (string-search whitesp val)(conc "'" val > 93 (print "export " (car key) "=" sval))) > 94 envvars))))) > 95 > 96 ;; set some env vars from an alist, return an alist with original values > 97 ;; (("VAR" "value") ...) > 98 (define (alist->env-vars lst) > 99 (if (list? lst) > 100 (let ((res '())) > 101 (for-each (lambda (p) > 102 (let* ((var (car p)) > 103 (val (cadr p)) > 104 (prv (get-environment-variable var))) > 105 (set! res (cons (list var prv) res)) > 106 (if val > 107 (setenv var (->string val)) > 108 (unsetenv var)))) > 109 lst) > 110 res) > 111 '())) > 112
Added configf.scm version [fc6ecb37be7e523b]
> 1 ;;====================================================================== > 2 ;; Copyright 2006-2011, Matthew Welland. > 3 ;; > 4 ;; This program is made available under the GNU GPL version 2.0 or > 5 ;; greater. See the accompanying file COPYING for details. > 6 ;; > 7 ;; This program is distributed WITHOUT ANY WARRANTY; without even the > 8 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR > 9 ;; PURPOSE. > 10 ;;====================================================================== > 11 > 12 ;;====================================================================== > 13 ;; Config file handling > 14 ;;====================================================================== > 15 > 16 ;; return list (path fullpath configname) > 17 (define (find-config configname) > 18 (let* ((cwd (string-split (current-directory) "/"))) > 19 (let loop ((dir cwd)) > 20 (let* ((path (conc "/" (string-intersperse dir "/"))) > 21 (fullpath (conc path "/" configname))) > 22 (if (file-exists? fullpath) > 23 (list path fullpath configname) > 24 (let ((remcwd (take dir (- (length dir) 1)))) > 25 (if (null? remcwd) > 26 (list #f #f #f) ;; #f #f) > 27 (loop remcwd)))))))) > 28 > 29 (define (config:assoc-safe-add alist key val) > 30 (let ((newalist (filter (lambda (x)(not (equal? key x))) alist))) > 31 (append alist (list (list key val))))) > 32 > 33 ;; read a config file, returns two level hierarchial hash-table, > 34 ;; adds to ht if given (must be #f otherwise) > 35 (define (read-config path . ht) > 36 (if (not (file-exists? path)) > 37 (if (null? ht)(make-hash-table) (car ht)) > 38 (let ((inp (open-input-file path)) > 39 (res (if (null? ht)(make-hash-table)(car ht))) > 40 (include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) > 41 (section-rx (regexp "^\\[(.*)\\]\\s*$")) > 42 (blank-l-rx (regexp "^\\s*$")) > 43 (key-val-pr (regexp "^(\\S+)\\s+(.*)$")) > 44 (comment-rx (regexp "^\\s*#.*"))) > 45 (let loop ((inl (read-line inp)) > 46 (curr-section-name "default")) > 47 (if (eof-object? inl) res > 48 (regex-case > 49 inl > 50 (comment-rx _ (loop (read-line inp) curr-section > 51 (blank-l-rx _ (loop (read-line inp) curr-section > 52 (include-rx ( x include-file ) (begin > 53 (read-config include-file res) > 54 (loop (read-line inp) curr-secti > 55 (section-rx ( x section-name ) (loop (read-line inp) section-name > 56 (key-val-pr ( x key val ) (let ((alist (hash-table-ref/defau > 57 (hash-table-set! res curr-sectio > 58 (config:assoc-s > 59 ;; (append alis > 60 (loop (read-line inp) curr-secti > 61 (else (print "ERROR: Should not get here,\n \"" inl "\"") > 62 (loop (read-line inp) curr-section-name)))))))) > 63 > 64 (define (find-and-read-config fname) > 65 (let* ((configinfo (find-config fname)) > 66 (toppath (car configinfo)) > 67 (configfile (cadr configinfo)) > 68 (configdat (if configfile (read-config configfile) #f))) ;; (make-hash > 69 (list configdat toppath configfile fname))) > 70 > 71 (define (config-lookup cfgdat section var) > 72 (let ((sectdat (hash-table-ref/default cfgdat section '()))) > 73 (if (null? sectdat) > 74 #f > 75 (let ((match (assoc var sectdat))) > 76 (if match > 77 (cadr match) > 78 #f)) > 79 ))) > 80 > 81 (define (setup) > 82 (let* ((configf (find-config)) > 83 (config (if configf (read-config configf) #f))) > 84 (if config > 85 (setenv "RUN_AREA_HOME" (pathname-directory configf))) > 86 config)) > 87
Added dashboard.scm version [58d8d13c30b5e647]
> 1 ;;====================================================================== > 2 ;; Copyright 2006-2011, Matthew Welland. > 3 ;; > 4 ;; This program is made available under the GNU GPL version 2.0 or > 5 ;; greater. See the accompanying file COPYING for details. > 6 ;; > 7 ;; This program is distributed WITHOUT ANY WARRANTY; without even the > 8 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR > 9 ;; PURPOSE. > 10 ;;====================================================================== > 11 > 12 (require-library iup) > 13 (import (prefix iup iup:)) > 14 > 15 ;; (use canvas-draw) > 16 > 17 (use sqlite3 srfi-1 posix regex regex-case srfi-69) > 18 > 19 (import (prefix sqlite3 sqlite3:)) > 20 > 21 (include "../margs/margs.scm") > 22 (include "keys.scm") > 23 (include "items.scm") > 24 (include "db.scm") > 25 (include "configf.scm") > 26 (include "process.scm") > 27 (include "launch.scm") > 28 (include "runs.scm") > 29 (include "gui.scm") > 30 > 31 (if (not (setup-for-run)) > 32 (begin > 33 (print "Failed to find megatest.config, exiting") > 34 (exit 1))) > 35 > 36 (define *db* (open-db)) > 37 > 38 (define toplevel #f) > 39 (define dlg #f) > 40 (define max-test-num 0) > 41 (define *keys* (get-keys *db*)) > 42 (define dbkeys (map (lambda (x)(vector-ref x 0)) > 43 (append *keys* (list (vector "runname" "blah"))))) > 44 (define *header* #f) > 45 (define *allruns* '()) > 46 (define *buttondat* (make-hash-table)) ;; <run-id color text test run-key> > 47 (define *alltestnames* (make-hash-table)) ;; build a minimalized list of test na > 48 (define *alltestnamelst* '()) > 49 (define *searchpatts* (make-hash-table)) > 50 (define *num-runs* 10) > 51 (define *num-tests* 15) > 52 (define *start-run-offset* 0) > 53 (define *start-test-offset* 0) > 54 > 55 > 56 (define (message-window msg) > 57 (iup:show > 58 (iup:dialog > 59 (iup:vbox > 60 (iup:label msg #:margin "40x40"))))) > 61 > 62 (define (iuplistbox-fill-list lb items . default) > 63 (let ((i 1) > 64 (selected-item (if (null? default) #f (car default)))) > 65 (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) > 66 (for-each (lambda (item) > 67 (iup:attribute-set! lb (number->string i) item) > 68 (if selected-item > 69 (if (equal? selected-item item) > 70 (iup:attribute-set! lb "VALUE" item))) ;; (number->strin > 71 (set! i (+ i 1))) > 72 items) > 73 i)) > 74 > 75 (define (pad-list l n)(append l (make-list (- n (length l))))) > 76 > 77 (define (examine-test button-key) ;; run-id run-key origtest) > 78 (let ((buttondat (hash-table-ref/default *buttondat* button-key #f))) > 79 ;; (print "buttondat: " buttondat) > 80 (if (and buttondat > 81 (vector buttondat) > 82 (vector-ref buttondat 0) > 83 (> (vector-ref buttondat 0) 0) > 84 (vector? (vector-ref buttondat 3)) > 85 (> (vector-ref (vector-ref buttondat 3) 0) 0)) > 86 (let* ((run-id (vector-ref buttondat 0)) > 87 (origtest (vector-ref buttondat 3)) > 88 (run-key (vector-ref buttondat 4)) > 89 (test (db:get-test-info *db* > 90 run-id > 91 (db:test-get-testname origtest) > 92 (db:test-get-item-path origtest)) > 93 (rundir (db:test-get-rundir test)) > 94 (testname (db:test-get-testname test)) > 95 (itempath (db:test-get-item-path test)) > 96 (testfullname (runs:test-get-full-path test)) > 97 (currstatus (db:test-get-status test)) > 98 (currstate (db:test-get-state test)) > 99 (currcomment (db:test-get-comment test)) > 100 (logfile (conc (db:test-get-rundir test) "/" (db:test-get-fi > 101 (viewlog (lambda (x) > 102 (if (file-exists? logfile) > 103 (system (conc "firefox " logfile "&")) > 104 (message-window (conc "File " logfile " not f > 105 (xterm (lambda (x) > 106 (if (directory-exists? rundir) > 107 (system (conc "cd " rundir ";xterm -T " (stri > 108 (message-window (conc "Directory " rundir " > 109 (newstatus currstatus) > 110 (newstate currstate) > 111 (self #f)) > 112 > 113 ;; (test-set-status! db run-id test-name state status itemdat) > 114 (set! self > 115 (iup:dialog > 116 (iup:vbox > 117 (iup:hbox > 118 (iup:frame (iup:label run-key)) > 119 (iup:frame (iup:label (conc "TESTNAME:\n" testfullname) #:exp > 120 (iup:frame #:title "Actions" #:expand "YES" > 121 (iup:hbox ;; the actions box > 122 (iup:button "View Log" #:action viewlog #:expa > 123 (iup:button "Start Xterm" #:action xterm #:expand > 124 (iup:frame #:title "Set fields" > 125 (iup:vbox > 126 (iup:hbox > 127 (iup:vbox ;; the state > 128 (iup:label "STATE:" #:size "30x") > 129 (let ((lb (iup:listbox #:action (lambda (val a b > 130 ;; (print val > 131 (set! newstate > 132 #:editbox "YES" > 133 #:expand "YES"))) > 134 (iuplistbox-fill-list lb > 135 (list "COMPLETED" "NOT_S > 136 currstate) > 137 lb)) > 138 (iup:vbox ;; the status > 139 (iup:label "STATUS:" #:size "30x") > 140 (let ((lb (iup:listbox #:action (lambda (val a b > 141 (set! newstatu > 142 #:editbox "YES" > 143 #:value currstatus > 144 #:expand "YES"))) > 145 (iuplistbox-fill-list lb > 146 (list "PASS" "FAIL" "n/a > 147 currstatus) > 148 lb))) > 149 (iup:hbox (iup:label "Comment:") > 150 (iup:textbox #:action (lambda (val a b) > 151 (set! currcommen > 152 #:value currcomment > 153 #:expand "YES")) > 154 (iup:button "Apply" > 155 #:expand "YES" > 156 #:action (lambda (x) > 157 (test-set-status! *db* run- > 158 (iup:hbox (iup:button "Apply and close" > 159 #:expand "YES" > 160 #:action (lambda (x) > 161 (test-set-status! > 162 (iup:destroy! sel > 163 (iup:button "Cancel and close" > 164 #:expand "YES" > 165 #:action (lambda (x) > 166 (iup:destroy! sel > 167 ))))) > 168 (iup:show self) > 169 )))) > 170 > 171 (define (colors-similar? color1 color2) > 172 (let* ((c1 (map string->number (string-split color1))) > 173 (c2 (map string->number (string-split color2))) > 174 (delta (map (lambda (a b)(abs (- a b))) c1 c2))) > 175 (null? (filter (lambda (x)(> x 3)) delta)))) > 176 > 177 (define (update-rundat patt numruns) > 178 (let* ((allruns (db-get-runs *db* patt numruns *start-run-offset*)) > 179 (header (db:get-header allruns)) > 180 (runs (db:get-rows allruns)) > 181 (result '()) > 182 (maxtests 0)) > 183 (for-each (lambda (run) > 184 (let* ((run-id (db-get-value-by-header run header "id")) > 185 (tests (db-get-tests-for-run *db* run-id)) > 186 (key-vals (get-key-vals *db* run-id))) > 187 (if (> (length tests) maxtests) > 188 (set! maxtests (length tests))) > 189 (set! result (cons (vector run tests key-vals) result)))) > 190 runs) > 191 (set! *header* header) > 192 (set! *allruns* (reverse result)) > 193 maxtests)) > 194 > 195 (define (update-labels uidat) > 196 (let* ((rown 0) > 197 (lftcol (vector-ref uidat 0)) > 198 (maxn (- (vector-length lftcol) 1))) > 199 (let loop ((i 0)) > 200 (iup:attribute-set! (vector-ref lftcol i) "TITLE" "") > 201 (if (<= i rown) > 202 (loop (+ i 1)))) > 203 (for-each (lambda (name) > 204 (if (<= rown maxn) > 205 (let ((labl (vector-ref lftcol rown))) > 206 (iup:attribute-set! labl "TITLE" name))) > 207 (set! rown (+ 1 rown))) > 208 (drop *alltestnamelst* *start-test-offset*)))) > 209 > 210 (define (update-buttons uidat numruns numtests) > 211 (let* ((runs (if (> (length *allruns*) numruns) > 212 (take-right *allruns* numruns) > 213 (pad-list *allruns* numruns))) > 214 (lftcol (vector-ref uidat 0)) > 215 (tableheader (vector-ref uidat 1)) > 216 (table (vector-ref uidat 2)) > 217 (coln 0)) > 218 (update-labels uidat) > 219 (for-each > 220 (lambda (rundat) > 221 (if (not rundat) ;; handle padded runs > 222 ;; ;; id run-id testname state status event-time host > 223 (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *ke > 224 (let* ((run (vector-ref rundat 0)) > 225 (testsdat (vector-ref rundat 1)) > 226 (key-val-dat (vector-ref rundat 2)) > 227 (run-id (db-get-value-by-header run *header* "id")) > 228 (testnames (delete-duplicates (append *alltestnamelst* > 229 (map test:test-get-fullname > 230 (key-vals (append key-val-dat > 231 (list (let ((x (db-get-value-by-header run *head > 232 (if x x ""))))) > 233 (run-key (string-intersperse key-vals "\n"))) > 234 ;; (run-ht (hash-table-ref/default alldat run-key #f))) > 235 ;; fill in the run header key values > 236 (let ((rown 0) > 237 (headercol (vector-ref tableheader coln))) > 238 (for-each (lambda (kval) > 239 (let* ((labl (vector-ref headercol rown))) > 240 (if (not (equal? kval (iup:attribute labl "TITLE"))) > 241 (iup:attribute-set! (vector-ref headercol rown) "TI > 242 (set! rown (+ rown 1)))) > 243 key-vals)) > 244 > 245 ;; For this run now fill in the buttons for each test > 246 (let ((rown 0) > 247 (columndat (vector-ref table coln))) > 248 (for-each > 249 (lambda (testname) > 250 (let ((buttondat (hash-table-ref/default *buttondat* (mkstr coln > 251 (if buttondat > 252 (let* ((test (let ((matching (filter > 253 (lambda (x)(equal? (test > 254 testsdat))) > 255 (if (null? matching) > 256 (vector -1 -1 "" "" "" 0 "" "" 0 "" > 257 (car matching)))) > 258 ;; (test (if real-test real-test > 259 (testname (db:test-get-testname test)) > 260 (itempath (db:test-get-item-path test)) > 261 (testfullname (test:test-get-fullname test)) > 262 (teststatus (db:test-get-status test)) > 263 (teststate (db:test-get-state test)) > 264 (buttontxt (if (equal? teststate "COMPLETED") testst > 265 (button (vector-ref columndat rown)) > 266 (color (case (string->symbol teststate) > 267 ((COMPLETED) > 268 (if (equal? teststatus "PASS") "70 249 > 269 ((LAUNCHED) "101 123 142") > 270 ((REMOTEHOSTSTART) "50 130 195") > 271 ((RUNNING) "9 131 232") > 272 ((KILLREQ) "39 82 206") > 273 ((KILLED) "234 101 17") > 274 (else "192 192 192"))) > 275 (curr-color (vector-ref buttondat 1)) ;; (iup:attribu > 276 (curr-title (vector-ref buttondat 2))) ;; (iup:attrib > 277 (if (not (equal? curr-color color)) > 278 (iup:attribute-set! button "BGCOLOR" color)) > 279 (if (not (equal? curr-title buttontxt)) > 280 (iup:attribute-set! button "TITLE" buttontxt)) > 281 (vector-set! buttondat 0 run-id) > 282 (vector-set! buttondat 1 color) > 283 (vector-set! buttondat 2 buttontxt) > 284 (vector-set! buttondat 3 test) > 285 (vector-set! buttondat 4 run-key) > 286 (if (not (hash-table-ref/default *alltestnames* testfullna > 287 (begin > 288 (hash-table-set! *alltestnames* testfullname #t) > 289 (set! *alltestnamelst* (append *alltestnamelst* (lis > 290 ) > 291 (set! rown (+ rown 1)))) > 292 (drop testnames *start-test-offset*))) > 293 (set! coln (+ coln 1)))) > 294 runs))) > 295 > 296 (define (mkstr . x) > 297 (string-intersperse (map conc x) ",")) > 298 > 299 (define (update-search x val) > 300 (print "Setting search for " x " to " val) > 301 (hash-table-set! *searchpatts* x val)) > 302 > 303 (define (make-dashboard-buttons nruns ntests keynames) > 304 (let* ((nkeys (length keynames)) > 305 (runsvec (make-vector nruns)) > 306 (header (make-vector nruns)) > 307 (lftcol (make-vector ntests)) > 308 (controls '()) > 309 (lftlst '()) > 310 (hdrlst '()) > 311 (bdylst '()) > 312 (result '()) > 313 (i 0)) > 314 ;; controls (along bottom) > 315 (set! controls > 316 (iup:hbox > 317 (iup:button "Quit" #:action (lambda (obj)(sqlite3:finalize! *db*)(exi > 318 (iup:button "<- Left" #:action (lambda (obj)(set! *start-run-offset* > 319 (iup:button "Up ^" #:action (lambda (obj)(set! *start-test-offset > 320 (iup:button "Down v" #:action (lambda (obj)(set! *start-test-offset > 321 (iup:button "Right ->" #:action (lambda (obj)(set! *start-run-offset* > 322 > 323 ;; create the left most column for the run key names and the test names > 324 (set! lftlst (list (apply iup:vbox > 325 (map (lambda (x) > 326 (let ((res (iup:hbox > 327 (iup:label x #:size "40x15" #:f > 328 (iup:textbox #:size "60x15" #:f > 329 #:action (lambda ( > 330 (update > 331 (set! i (+ i 1)) > 332 res)) > 333 keynames)))) > 334 (let loop ((testnum 0) > 335 (res '())) > 336 (cond > 337 ((>= testnum ntests) > 338 ;; now lftlst will be an hbox with the test keys and the test name label > 339 (set! lftlst (append lftlst (list (apply iup:vbox (reverse res)))))) > 340 (else > 341 (let ((labl (iup:button "" #:flat "YES" #:size "100x15" #:fontsize "10" > 342 (vector-set! lftcol testnum labl) > 343 (loop (+ testnum 1)(cons labl res)))))) > 344 ;; > 345 (let loop ((runnum 0) > 346 (keynum 0) > 347 (keyvec (make-vector nkeys)) > 348 (res '())) > 349 (cond ;; nb// no else for this approach. > 350 ((>= runnum nruns) #f) > 351 ((>= keynum nkeys) > 352 (vector-set! header runnum keyvec) > 353 (set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst)) > 354 (loop (+ runnum 1) 0 (make-vector nkeys) '())) > 355 (else > 356 (let ((labl (iup:label "" #:size "60x15" #:fontsize "10" ;; #:expand "H > 357 ))) > 358 (vector-set! keyvec keynum labl) > 359 (loop runnum (+ keynum 1) keyvec (cons labl res)))))) > 360 ;; By here the hdrlst contains a list of vboxes containing nkeys labels > 361 (let loop ((runnum 0) > 362 (testnum 0) > 363 (testvec (make-vector ntests)) > 364 (res '())) > 365 (cond > 366 ((>= runnum nruns) #f) ;; (vector tableheader runsvec)) > 367 ((>= testnum ntests) > 368 (vector-set! runsvec runnum testvec) > 369 (set! bdylst (cons (apply iup:vbox (reverse res)) bdylst)) > 370 (loop (+ runnum 1) 0 (make-vector ntests) '())) > 371 (else > 372 (let* ((button-key (mkstr runnum testnum)) > 373 (butn (iup:button "" ;; button-key > 374 #:size "60x15" > 375 ;; #:expand "HORIZONTAL" > 376 #:fontsize "10" > 377 #:action (lambda (x) > 378 (examine-test button-key))))) > 379 (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button > 380 (vector-set! testvec testnum butn) > 381 (loop runnum (+ testnum 1) testvec (cons butn res)))))) > 382 ;; now assemble the hdrlst and bdylst and kick off the dialog > 383 (iup:show > 384 (iup:dialog > 385 #:title "Megatest dashboard" > 386 (iup:vbox > 387 (apply iup:hbox > 388 (cons (apply iup:vbox lftlst) > 389 (list > 390 (iup:vbox > 391 ;; the header > 392 (apply iup:hbox (reverse hdrlst)) > 393 (apply iup:hbox (reverse bdylst)))))) > 394 controls))) > 395 (vector lftcol header runsvec))) > 396 > 397 (set! *num-tests* (max (update-rundat "%" *num-runs*) 8)) > 398 > 399 (set! uidat (make-dashboard-buttons *num-runs* *num-tests* dbkeys)) > 400 ;; (megatest-dashboard) > 401 > 402 (define (run-update other-thread) > 403 (let loop ((i 0)) > 404 (thread-sleep! 0.1) > 405 (thread-suspend! other-thread) > 406 (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-run > 407 (update-buttons uidat *num-runs* *num-tests*) > 408 (thread-resume! other-thread) > 409 (loop (+ i 1)))) > 410 > 411 (define th2 (make-thread iup:main-loop)) > 412 (define th1 (make-thread (run-update th2))) > 413 (thread-start! th1) > 414 (thread-start! th2) > 415 (thread-join! th2)
Added db.scm version [764f6c91ad07200b]
> 1 ;;====================================================================== > 2 ;; Copyright 2006-2011, Matthew Welland. > 3 ;; > 4 ;; This program is made available under the GNU GPL version 2.0 or > 5 ;; greater. See the accompanying file COPYING for details. > 6 ;; > 7 ;; This program is distributed WITHOUT ANY WARRANTY; without even the > 8 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR > 9 ;; PURPOSE. > 10 ;;====================================================================== > 11 > 12 ;;====================================================================== > 13 ;; Database access > 14 ;;====================================================================== > 15 > 16 (define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) > 17 (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) > 18 (configdat (car *configinfo*)) > 19 (dbexists (file-exists? dbpath)) > 20 (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db db > 21 (handler (make-busy-timeout 36000))) > 22 (sqlite3:set-busy-handler! db handler) > 23 (if (not dbexists) > 24 (let* ((keys (config-get-fields configdat)) > 25 (havekeys (> (length keys) 0)) > 26 (keystr (keys->keystr keys)) > 27 (fieldstr (keys->key/field keys))) > 28 ;; (sqlite3:execute db "PRAGMA synchronous = OFF;") > 29 (sqlite3:execute db "CREATE TABLE keys (id INTEGER PRIMARY KEY, fieldn > 30 (for-each (lambda (key) > 31 (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype > 32 keys) > 33 (sqlite3:execute db (conc > 34 "CREATE TABLE runs (id INTEGER PRIMARY KEY, " > 35 fieldstr (if havekeys "," "") > 36 "runname TEXT," > 37 "state TEXT DEFAULT ''," > 38 "status TEXT DEFAULT ''," > 39 "owner TEXT DEFAULT ''," > 40 "event_time TIMESTAMP," > 41 "comment TEXT DEFAULT ''," > 42 "CONSTRAINT runsconstraint UNIQUE (runname" (if have > 43 (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" ( > 44 (sqlite3:execute db > 45 "CREATE TABLE tests > 46 (id INTEGER PRIMARY KEY, > 47 run_id INTEGER, > 48 testname TEXT, > 49 itempath TEXT, > 50 host TEXT DEFAULT 'n/a', > 51 cpuload REAL DEFAULT -1, > 52 diskfree INTEGER DEFAULT -1, > 53 uname TEXT DEFAULT 'n/a', > 54 rundir TEXT DEFAULT 'n/a', > 55 item_path TEXT DEFAULT '', > 56 state TEXT DEFAULT 'NOT_STARTED', > 57 status TEXT DEFAULT 'n/a', > 58 attemptnum INTEGER DEFAULT 0, > 59 final_logf TEXT DEFAULT 'logs/final.log', > 60 logdat BLOB, > 61 run_duration INTEGER DEFAULT 0, > 62 comment TEXT DEFAULT '', > 63 event_time TIMESTAMP, > 64 CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_p > 65 );") > 66 (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testna > 67 (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNE > 68 (sqlite3:execute db "CREATE TABLE test_steps > 69 (id INTEGER PRIMARY KEY, > 70 test_id INTEGER, > 71 stepname TEXT, > 72 state TEXT DEFAULT 'NOT_STARTED', > 73 status TEXT DEFAULT 'n/a',event_time TIMESTAMP, > 74 comment TEXT DEFAULT '', > 75 CONSTRAINT test_steps_constraint UNIQUE (test_id, > 76 (sqlite3:execute db "CREATE TABLE extradat (id INTEGER PRIMARY KEY, ru > 77 (sqlite3:execute db "CREATE TABLE access_log (id INTEGER PRIMARY KEY, > 78 db)) > 79 > 80 ;; (if (args:get-arg "-db") > 81 ;; (set! db (open-db (args:get-arg "-db")))) > 82 > 83 ;; TODO > 84 ;; > 85 ;; 1. Implement basic registering of records > 86 ;; 2. Implement basic querying of records > 87 ;; eh? > 88 > 89 (define (db-get-keys db) > 90 (let ((res '())) > 91 (sqlite3:for-each-row > 92 (lambda (key keytype) > 93 (set! res (cons (vector key keytype) res))) > 94 db > 95 "SELECT fieldname,fieldtype FROM keys ORDER BY id DESC;") > 96 res)) > 97 > 98 > 99 (define-inline (db:get-header vec)(vector-ref vec 0)) > 100 (define-inline (db:get-rows vec)(vector-ref vec 1)) > 101 > 102 (define (db-get-value-by-header row header field) > 103 (if (null? header) #f > 104 (let loop ((hed (car header)) > 105 (tal (cdr header)) > 106 (n 0)) > 107 (if (equal? hed field) > 108 (vector-ref row n) > 109 (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))) > 110 > 111 (define (db-get-runs db runpatt . count) > 112 (let* ((res '()) > 113 (keys (db-get-keys db)) > 114 (remfields (list "id" "runname" "state" "status" "owner" "event_time")) > 115 (header (append (map key:get-fieldname keys) > 116 remfields)) > 117 (keystr (conc (keys->keystr keys) "," > 118 (string-intersperse remfields ",")))) > 119 (sqlite3:for-each-row > 120 (lambda (a . x) > 121 (set! res (cons (apply vector a x) res))) > 122 db > 123 (conc "SELECT " keystr " FROM runs WHERE runname LIKE ? ORDER BY event_time > 124 (if (and (not (null? count)) > 125 (number? (car count))) > 126 (conc " LIMIT " (car count)) > 127 "") > 128 (if (and (> (length count) 1) > 129 (number? (cadr count))) > 130 (conc " OFFSET " (cadr count)) > 131 "")) > 132 runpatt) > 133 (vector header res))) > 134 > 135 ;; use this one for db-get-run-info > 136 (define-inline (db:get-row vec)(vector-ref vec 1)) > 137 > 138 ;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) > 139 (define (db-get-run-info db run-id) > 140 (let* ((res #f) > 141 (keys (db-get-keys db)) > 142 (remfields (list "id" "runname" "state" "status" "owner" "event_time")) > 143 (header (append (map key:get-fieldname keys) > 144 remfields)) > 145 (keystr (conc (keys->keystr keys) "," > 146 (string-intersperse remfields ",")))) > 147 (sqlite3:for-each-row > 148 (lambda (a . x) > 149 (set! res (apply vector a x))) > 150 db > 151 (conc "SELECT " keystr " FROM runs WHERE id=?;") > 152 run-id) > 153 (vector header res))) > 154 > 155 ;; Tests > 156 (define (make-db:test)(make-vector 6)) > 157 (define-inline (db:test-get-id vec) (vector-ref vec 0)) > 158 (define-inline (db:test-get-run_id vec) (vector-ref vec 1)) > 159 (define-inline (db:test-get-testname vec) (vector-ref vec 2)) > 160 (define-inline (db:test-get-state vec) (vector-ref vec 3)) > 161 (define-inline (db:test-get-status vec) (vector-ref vec 4)) > 162 (define-inline (db:test-get-event_time vec) (vector-ref vec 5)) > 163 (define-inline (db:test-get-host vec) (vector-ref vec 6)) > 164 (define-inline (db:test-get-cpuload vec) (vector-ref vec 7)) > 165 (define-inline (db:test-get-diskfree vec) (vector-ref vec 8)) > 166 (define-inline (db:test-get-uname vec) (vector-ref vec 9)) > 167 (define-inline (db:test-get-rundir vec) (vector-ref vec 10)) > 168 (define-inline (db:test-get-item-path vec) (vector-ref vec 11)) > 169 (define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) > 170 (define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) > 171 (define-inline (db:test-get-comment vec) (vector-ref vec 14)) > 172 > 173 (define (db-get-tests-for-run db run-id) > 174 (let ((res '())) > 175 (sqlite3:for-each-row > 176 (lambda (id run-id testname state status event-time host cpuload diskfree u > 177 (set! res (cons (vector id run-id testname state status event-time host c > 178 db > 179 "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,un > 180 run-id) > 181 res)) > 182 > 183 ;; NB// Sync this with runs:get-test-info > 184 (define (db:get-test-info db run-id testname item-path) > 185 (let ((res '())) > 186 (sqlite3:for-each-row > 187 (lambda (id run-id testname state status event-time host cpuload diskfree u > 188 (set! res (vector id run-id testname state status event-time host cpuload > 189 db > 190 "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,un > 191 run-id testname item-path) > 192 res)) > 193 > 194 ;; Steps > 195 ;; Run steps > 196 ;; make-vector-record "Run steps" db step id test_id stepname step_complete step > 197 (define (make-db:step)(make-vector 6)) > 198 (define-inline (db:step-get-id vec) (vector-ref vec 0)) > 199 (define-inline (db:step-get-test_id vec) (vector-ref vec 1)) > 200 (define-inline (db:step-get-stepname vec) (vector-ref vec 2)) > 201 (define-inline (db:step-get-state vec) (vector-ref vec 3)) > 202 (define-inline (db:step-get-status vec) (vector-ref vec 4)) > 203 (define-inline (db:step-get-event_time vec) (vector-ref vec 5)) > 204 (define-inline (db:step-set-id! vec val)(vector-set! vec 0 val)) > 205 (define-inline (db:step-set-test_id! vec val)(vector-set! vec 1 val)) > 206 (define-inline (db:step-set-stepname! vec val)(vector-set! vec 2 val)) > 207 (define-inline (db:step-set-state! vec val)(vector-set! vec 3 val)) > 208 (define-inline (db:step-set-status! vec val)(vector-set! vec 4 val)) > 209 (define-inline (db:step-set-event_time! vec val)(vector-set! vec 5 val)) > 210 > 211 (define (db-get-test-steps-for-run db test-id) > 212 (let ((res '())) > 213 (sqlite3:for-each-row > 214 (lambda (id test-id stepname state status event-time) > 215 (set! res (cons (vector id test-id stepname state status event-time) res) > 216 db > 217 "SELECT id,test_id,stepname,state,status,event_time FROM test_steps WHERE t > 218 test-id) > 219 res)) > 220 > 221 ;; check that *all* the prereqs are "COMPLETED" > 222 (define (db-get-prereqs-met db run-id waiton) > 223 (let ((res #f) > 224 (not-complete 0) > 225 (tests (db-get-tests-for-run db run-id))) > 226 (for-each > 227 (lambda (test-name) > 228 (for-each > 229 (lambda (test) > 230 (if (equal? (db:test-get-testname test) test-name) > 231 (begin > 232 (set! res #t) > 233 (if (not (equal? (db:test-get-state test) "COMPLETED")) > 234 (set! not-complete (+ 1 not-complete)))))) > 235 tests)) > 236 waiton) > 237 (and (or (null? waiton) res) > 238 (eq? not-complete 0)))) > 239 > 240 ;; USE: (lset-difference string=? '("a" "b" "c") '("d" "c" "e" "a")) > 241 ;; > 242 ;; Return a list of prereqs that were NOT met > 243 ;; Tests (and all items) in waiton list must be "COMPLETED" and "PASS" > 244 (define (db-get-prereqs-not-met db run-id waiton) > 245 (if (null? waiton) > 246 '() > 247 (let* ((unmet-pre-reqs '()) > 248 (tests (db-get-tests-for-run db run-id)) > 249 (result '())) > 250 (for-each (lambda (waitontest-name) > 251 (let ((ever-seen #f)) > 252 (for-each (lambda (test) > 253 (if (equal? waitontest-name (db:test-get-testn > 254 (begin > 255 (set! ever-seen #t) > 256 (if (not (and (equal? (db:test-get-state > 257 (equal? (db:test-get-statu > 258 (set! result (cons waitontest-name r > 259 tests) > 260 (if (not ever-seen)(set! result (cons waitontest-name resu > 261 waiton) > 262 (delete-duplicates result)))) > 263 ;; > 264 ;; ;; subtract from the waiton list the "COMPLETED" tests > 265 ;; ;;(completed-tests (filter (lambda (x) > 266 ;; ;; (equal? (db:test-get-state x) "COMPLETED > 267 ;; ;; tests)) > 268 ;; (completed-tests (let ((non-completed (make-hash-table))) > 269 ;; (for-each (lambda (x) > 270 ;; ;; could add check for PASS here > 271 ;; (if (not (and (equal? (db:test-get-s > 272 ;; (equal? (db:test-get-s > 273 ;; (hash-table-set! non-completed ( > 274 ;; ;; (print "Completed: " (db:test-get > 275 ;; tests) > 276 ;; (filter (lambda (x) > 277 ;; (not (hash-table-ref/default non-compl > 278 ;; tests))) > 279 ;; (pre-dep-names (map db:test-get-testname completed-tests)) > 280 ;; (result (lset-difference string=? waiton pre-dep-names))) > 281 ;; (print "pre-dep-names: " pre-dep-names " waiton: " waiton " result: " re
Added docs/screenshot.png version [54649cfc575ad9f6]
cannot compute difference between binary files
Added gui.scm version [b2ab4d1a14bf131c]
> 1 > 2 ;; Copyright 2006-2011, Matthew Welland. > 3 ;; > 4 ;; This program is made available under the GNU GPL version 2.0 or > 5 ;; greater. See the accompanying file COPYING for details. > 6 ;; > 7 ;; This program is distributed WITHOUT ANY WARRANTY; without even the > 8 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR > 9 ;; PURPOSE. > 10 > 11 ;; (define (celsius->fahrenheit item) > 12 ;; (let ((number (string->number item))) > 13 ;; (if (number? number) > 14 ;; (+ (* number 9/5) 32) > 15 ;; 0.0))) > 16 > 17 ;; (define (megatest-gui-1) > 18 ;; (use pstk) > 19 ;; (handle-exceptions > 20 ;; exn > 21 ;; (tk-end) ; make sure tk is closed in event of any error > 22 ;; > 23 ;; (tk-start) > 24 ;; (tk/wm 'title tk "Celsius to Fahrenheit") > 25 ;; (let* ((celsius (tk 'create-widget 'entry)) > 26 ;; (label (tk 'create-widget 'label)) > 27 ;; (button (tk 'create-widget 'button > 28 ;; 'text: 'Calculate > 29 ;; 'command: (lambda () > 30 ;; (label 'configure > 31 ;; 'text: (number->string (celsius->fahren > 32 ;; ; layout widgets in a grid > 33 ;; (tk/grid celsius 'column: 2 'row: 1 'sticky: 'we 'padx: 5 'pady: 5) > 34 ;; (tk/grid label 'column: 2 'row: 2 'sticky: 'we 'padx: 5 'pady: 5) > 35 ;; (tk/grid button 'column: 2 'row: 3 'sticky: 'we 'padx: 5 'pady: 5) > 36 ;; (tk/grid (tk 'create-widget 'label 'text: "celsius") > 37 ;; 'column: 3 'row: 1 'sticky: 'w 'padx: 5 'pady: 5) > 38 ;; (tk/grid (tk 'create-widget 'label 'text: "is") > 39 ;; 'column: 1 'row: 2 'sticky: 'e 'padx: 5 'pady: 5) > 40 ;; (tk/grid (tk 'create-widget 'label 'text: "fahrenheit") > 41 ;; 'column: 3 'row: 2 'sticky: 'w 'padx: 5 'pady: 5) > 42 ;; ; rest of gui setup > 43 ;; (tk-event-loop)) > 44 ;; )) > 45 > 46 (define (init-dialog) > 47 ;; (let ((controls-frame (iup:frame > 48 ;; (iup:hbox > 49 #t) > 50 > 51 ;; For now the gui work will be done in dashboard.scm > 52 > 53 ;;(define (megatest-gui) > 54 ;; (require-library iup) > 55 ;; (import (prefix iup iup:)) > 56 ;; (use canvas-draw canvas-draw-iup) > 57 ;; (use srfi-4)) > 58
Added items.scm version [1d66604c3291da8a]
> 1 > 2 ;; Copyright 2006-2011, Matthew Welland. > 3 ;; > 4 ;; This program is made available under the GNU GPL version 2.0 or > 5 ;; greater. See the accompanying file COPYING for details. > 6 ;; > 7 ;; This program is distributed WITHOUT ANY WARRANTY; without even the > 8 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR > 9 ;; PURPOSE. > 10 > 11 > 12 ;; (define itemdat '((ripeness "green ripe overripe") > 13 ;; (temperature "cool medium hot") > 14 ;; (season "summer winter fall spring"))) > 15 > 16 ;; Mostly worked = puts out all combinations? > 17 (define (process-itemlist-try1 curritemkey itemlist) > 18 (let loop ((hed (car itemlist)) > 19 (tal (cdr itemlist))) > 20 (if (null? tal) > 21 (for-each (lambda (item) > 22 (print "curritemkey: " (append curritemkey (list item)))) > 23 (cadr hed)) > 24 (begin > 25 (for-each (lambda (item) > 26 (process-itemlist (append curritemkey (list item)) tal)) > 27 (cadr hed)) > 28 (loop (car tal)(cdr tal)))))) > 29 > 30 ;; Mostly worked = puts out all combinations? > 31 (define (process-itemlist hierdepth curritemkey itemlist) > 32 (let ((res '())) > 33 (if (not hierdepth) > 34 (set! hierdepth (length itemlist))) > 35 (let loop ((hed (car itemlist)) > 36 (tal (cdr itemlist))) > 37 (if (null? tal) > 38 (for-each (lambda (item) > 39 (if (> (length curritemkey) (- hierdepth 2)) > 40 (set! res (append res (list (append curritemkey (list > 41 (cadr hed)) > 42 (begin > 43 (for-each (lambda (item) > 44 (set! res (append res (process-itemlist hierdepth (appen > 45 (cadr hed)) > 46 (loop (car tal)(cdr tal))))) > 47 res)) > 48 > 49 (define (item-assoc->item-list itemsdat) > 50 (if (and itemsdat (not (null? itemsdat))) > 51 (let ((itemlst (map (lambda (x) > 52 (let ((name (car x)) > 53 (items (cadr x))) > 54 (list name (string-split items)))) > 55 itemsdat))) > 56 (process-itemlist #f '() itemlst)) > 57 '(()))) ;; return a list consisting on a single null list for non-item run > 58 > 59 (define-inline (item-list->path itemdat) > 60 (string-intersperse (map cadr itemdat) "/")) > 61 > 62 ;; (pp (item-assoc->item-list itemdat)) > 63 > 64 > 65
Added keys.scm version [b6f3133402cc77b8]
> 1 > 2 ;; Copyright 2006-2011, Matthew Welland. > 3 ;; > 4 ;; This program is made available under the GNU GPL version 2.0 or > 5 ;; greater. See the accompanying file COPYING for details. > 6 ;; > 7 ;; This program is distributed WITHOUT ANY WARRANTY; without even the > 8 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR > 9 ;; PURPOSE. > 10 > 11 ;;====================================================================== > 12 ;; Run keys, these are used to hierarchially organise tests and run areas > 13 ;;====================================================================== > 14 > 15 > 16 (define-inline (key:get-fieldname key)(vector-ref key 0)) > 17 (define-inline (key:get-fieldtype key)(vector-ref key 1)) > 18 > 19 (define (get-keys db) > 20 (let ((keys '())) ;; keys are vectors <fieldname,type> > 21 (sqlite3:for-each-row (lambda (fieldname fieldtype) > 22 (set! keys (cons (vector fieldname fieldtype) keys)) > 23 db > 24 "SELECT fieldname,fieldtype FROM keys ORDER BY id ASC; > 25 (reverse keys))) ;; could just sort desc? > 26 > 27 ;; get key vals for a given run-id > 28 (define (get-key-vals db run-id) > 29 (let* ((keys (get-keys db)) > 30 (res '())) > 31 ;; (print "keys: " keys " run-id: " run-id) > 32 (for-each > 33 (lambda (key) > 34 (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=? > 35 ;; (print "qry: " qry) > 36 (sqlite3:for-each-row > 37 (lambda (key-val) > 38 (set! res (cons key-val res))) > 39 db qry run-id))) > 40 keys) > 41 (reverse res))) > 42 > 43 (define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... > 44 (string-intersperse (map key:get-fieldname keys) ",")) > 45 > 46 (define-inline (keys->valslots keys) ;; => ?,?,? .... > 47 (string-intersperse (map (lambda (x) "?") keys) ",")) > 48 > 49 (define-inline (keys->key/field keys . additional) > 50 (string-join (map (lambda (k)(conc (key:get-fieldname k) " " (key:get-fieldtyp > 51 > 52 (define (args:usage . a) #f) > 53 > 54 ;; Using the keys pulled from the database (initially set from the megatest.conf > 55 ;; look for the equivalent value on the command line and add it to a list, or #f > 56 ;; default => (val1 val2 val3 ...) > 57 ;; withkey => (:key1 val1 :key2 val2 :key3 val3 ...) > 58 (define (keys->vallist keys . withkey) ;; ORDERING IS VERY IMPORTANT, KEEP PROPE > 59 (let* ((keynames (map key:get-fieldname keys)) > 60 (argkeys (map (lambda (k)(conc ":" k)) keynames)) > 61 (withkey (not (null? withkey))) > 62 (newremargs (args:get-args (cons "blah" remargs) argkeys '() args:arg-h > 63 ;;(print "remargs: " remargs " newremargs: " newremargs) > 64 (apply append (map (lambda (x) > 65 (let ((val (args:get-arg x))) > 66 ;; (print "x: " x " val: " val) > 67 (if (not val) > 68 ;; (print "WARNING: missing key " x ". Specified > 69 (set! val "default")) > 70 (if withkey (list x val) (list val)))) > 71 argkeys)))) > 72 > 73 ;; (define (keys->alist keys) > 74 ;; (let* ((keynames (map key:get-fieldname keys)) > 75 ;; (argkeys (map (lambda (k)(conc ":" k)) keynames)) > 76 ;; (withkey (not (null? withkey))) > 77 ;; (newremargs (args:get-args (cons "blah" remargs) argkeys '() args:arg-h > 78 ;; (print "remargs: " remargs " newremargs: " newremargs) > 79 ;; (apply append (map (lambda (x) > 80 ;; (let ((val (args:get-arg x))) > 81 ;; (if (not val) > 82 ;; (print "ERROR: Ignoring key " x " found in databa > 83 ;; (if withkey (list x val) (list val)))) > 84 ;; argkeys)))) > 85 > 86 (define (keystring->keys keystring) > 87 (map (lambda (x) > 88 (let ((xlst (string-split x ":"))) > 89 (list->vector (if (> (length xlst) 1) xlst (append (car xlst)(list "T > 90 (delete-duplicates (string-split keystring ",")))) > 91 > 92 (define (config-get-fields confdat) > 93 (let ((fields (hash-table-ref/default confdat "fields" '()))) > 94 (map (lambda (x)(vector (car x)(cadr x))) > 95 fields))) > 96
Added launch.scm version [c9e33dfffe235bd9]
> 1 > 2 ;; Copyright 2006-2011, Matthew Welland. > 3 ;; > 4 ;; This program is made available under the GNU GPL version 2.0 or > 5 ;; greater. See the accompanying file COPYING for details. > 6 ;; > 7 ;; This program is distributed WITHOUT ANY WARRANTY; without even the > 8 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR > 9 ;; PURPOSE. > 10 > 11 ;;====================================================================== > 12 ;; launch a task - this runs on the originating host, tests themselves > 13 ;; > 14 ;;====================================================================== > 15 > 16 (define (setup-for-run) > 17 (set! *configinfo* (find-and-read-config (if (args:get-arg "-config")(args:get > 18 (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) > 19 (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) > 20 (if *toppath* > 21 (setenv "MT_RUN_AREA_HOME" *toppath*) > 22 (print "ERROR: failed to find the top path to your run setup.")) > 23 *toppath*) > 24 > 25 (define (setup-env-defaults db fname run-id . already-seen) > 26 (let* ((keys (get-keys db)) > 27 (keyvals (get-key-vals db run-id)) > 28 (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) > 29 (confdat (read-config fname)) > 30 (whatfound (make-hash-table)) > 31 (sections (list "default" thekey))) > 32 ;; (print "Using key=\"" thekey "\"") > 33 (for-each > 34 (lambda (section) > 35 (let ((section-dat (hash-table-ref/default confdat section #f))) > 36 (if section-dat > 37 (for-each > 38 (lambda (envvar) > 39 (hash-table-set! whatfound section (+ (hash-table-ref/default wh > 40 (setenv envvar (cadr (assoc envvar section-dat)))) > 41 (map car section-dat))))) > 42 sections) > 43 (if (and (not (null? already-seen)) > 44 (not (car already-seen))) > 45 (begin > 46 (print "Key settings found in runconfig.config:") > 47 (for-each (lambda (fullkey) > 48 (format #t "~20a ~a\n" fullkey (hash-table-ref/default wha > 49 sections) > 50 (print "---") > 51 (set! *already-seen-runconfig-info* #t))))) > 52 > 53 (define (get-best-disk confdat) > 54 (let* ((disks (hash-table-ref/default confdat "disks" #f)) > 55 (best #f) > 56 (bestsize 0)) > 57 (if disks > 58 (for-each > 59 (lambda (disk-num) > 60 (let* ((dirpath (cadr (assoc disk-num disks))) > 61 (freespc (if (directory? dirpath) > 62 (get-df dirpath) > 63 (begin > 64 (print "WARNING: path " dirpath " in [disks] > 65 0)))) > 66 (if (> freespc bestsize) > 67 (begin > 68 (set! best dirpath) > 69 (set! bestsize freespc))))) > 70 (map car disks))) > 71 best)) > 72 > 73 (define (create-work-area db run-id test-path disk-path testname itemdat) > 74 (let* ((run-info (db-get-run-info db run-id)) > 75 (item-path (let ((ip (item-list->path itemdat))) > 76 (if (equal? ip "") "" (conc "/" ip)))) > 77 (runname (db-get-value-by-header (db:get-row run-info) > 78 (db:get-header run-info) > 79 "runname")) > 80 (key-vals (get-key-vals db run-id)) > 81 (key-str (string-intersperse key-vals "/")) > 82 (dfullp (conc disk-path "/" key-str "/" runname "/" testname > 83 item-path)) > 84 (lnkpath (conc *toppath* "/runs/" key-str "/" runname item-path))) > 85 (print "Setting up test run area") > 86 (print " - creating run area in " dfullp) > 87 (system (conc "mkdir -p " dfullp)) > 88 (print " - creating link from " dfullp "/" testname " to " lnkpath) > 89 (system (conc "mkdir -p " lnkpath)) > 90 (if (file-exists? (conc lnkpath "/" testname)) > 91 (system (conc "rm -f " lnkpath "/" testname))) > 92 (system (conc "ln -sf " dfullp " " lnkpath "/" testname)) > 93 (if (directory? dfullp) > 94 (begin > 95 (system (conc "rsync -av " test-path "/ " dfullp "/")) > 96 dfullp) > 97 #f))) > 98 > 99 ;; 1. look though disks list for disk with most space > 100 ;; 2. create run dir on disk, path name is meaningful > 101 ;; 3. create link from run dir to megatest runs area > 102 ;; 4. remotely run the test on allocated host > 103 ;; - could be ssh to host from hosts table (update regularly with load) > 104 ;; - could be netbatch > 105 ;; (launch-test db (cadr status) test-conf)) > 106 (define (launch-test db run-id test-conf keyvallst test-name test-path itemdat) > 107 (let ((launcher (config-lookup *configdat* "jobtools" "launcher")) > 108 (runscript (config-lookup test-conf "setup" "runscript")) > 109 (diskspace (config-lookup test-conf "requirements" "diskspace")) > 110 (memory (config-lookup test-conf "requirements" "memory")) > 111 (hosts (config-lookup *configdat* "jobtools" "workhosts")) > 112 (remote-megatest (config-lookup *configdat* "setup" "executable")) > 113 (local-megatest (car (argv))) > 114 ;; (item-path (item-list->path itemdat)) test-path is the full path inc > 115 (work-area #f) > 116 (diskpath #f) > 117 (cmdparms #f) > 118 (fullcmd #f));; (define a (with-output-to-string (lambda ()(write x)) > 119 (if hosts (set! hosts (string-split hosts))) > 120 (if (not remote-megatest)(set! remote-megatest "megatest")) > 121 (if launcher (set! launcher (string-split launcher))) > 122 ;; set up the run work area for this test > 123 (set! diskpath (get-best-disk *configdat*)) > 124 (if diskpath > 125 (set! work-area (create-work-area db run-id test-path diskpath test-name > 126 (begin > 127 (set! work-area test-path) > 128 (print "WARNING: No disk work area specified - running in the test dir > 129 (set! cmdparms (base64:base64-encode (with-output-to-string > 130 (lambda () ;; (list 'hosts hosts) > 131 (write (list (list 'testpath test-path) > 132 (list 'work-area work-area) > 133 (list 'test-name test-name) > 134 (list 'runscript runscript) > 135 (list 'run-id run-id ) > 136 (list 'itemdat itemdat))))) > 137 (change-directory work-area) ;; so that log files from the launch process do > 138 (cond > 139 ((and launcher hosts) ;; must be using ssh hostname > 140 (set! fullcmd (append launcher (car hosts)(list remote-megatest "-execute" > 141 (launcher > 142 (set! fullcmd (append launcher (list remote-megatest "-execute" cmdparms)) > 143 (else > 144 (set! fullcmd (list remote-megatest "-execute" cmdparms)))) > 145 (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) > 146 (print "Launching megatest for test " test-name " in " work-area" ...") > 147 (test-set-status! db run-id test-name "LAUNCHED" "n/a" itemdat) ;; (if launc > 148 ;; set "pre-launch-env-vars > 149 (let* ((prevvals (alist->env-vars > 150 (hash-table-ref/default test-conf "pre-launch-env-ov > 151 (launch-results (apply cmd-run-proc-each-line > 152 (car fullcmd) > 153 print > 154 (cdr fullcmd)))) ;; launcher fullcmd)));; (ap > 155 (print "Launching completed, updating db") > 156 (alist->env-vars prevvals)))) > 157
Added margs.scm version [8faad0d91ab1508e]
> 1 ;; Copyright 2007-2010, Matthew Welland. > 2 ;; > 3 ;; This program is made available under the GNU GPL version 2.0 or > 4 ;; greater. See the accompanying file COPYING for details. > 5 ;; > 6 ;; This program is distributed WITHOUT ANY WARRANTY; without even the > 7 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR > 8 ;; PURPOSE. > 9 > 10 (define args:arg-hash (make-hash-table)) > 11 > 12 (define (args:get-arg arg . default) > 13 (if (null? default) > 14 (hash-table-ref/default args:arg-hash arg #f) > 15 (hash-table-ref/default args:arg-hash arg (car default)))) > 16 > 17 (define (args:get-arg-from ht arg . default) > 18 (if (null? default) > 19 (hash-table-ref/default ht arg #f)) > 20 (hash-table-ref/default ht arg (car default))) > 21 > 22 (define (args:usage . args) > 23 (if (> (length args) 0) > 24 (apply print "ERROR: " args)) > 25 (if (string? help) > 26 (print help) > 27 (print "Usage: " (car (argv)) " ... ")) > 28 (exit 0)) > 29 > 30 ;; args: > 31 (define (args:get-args args params switches arg-hash num-needed) > 32 (let* ((numargs (length args)) > 33 (adj-num-needed (if num-needed (+ num-needed 2) #f))) > 34 (if (< numargs (if adj-num-needed adj-num-needed 2)) > 35 (if (>= num-needed 1) > 36 (args:usage "No arguments provided")) > 37 (let loop ((arg (cadr args)) > 38 (tail (cddr args)) > 39 (remargs '())) > 40 (cond > 41 ((member arg params) ;; args with params > 42 (if (< (length tail) 1) > 43 (args:usage "param given without argument " arg) > 44 (let ((val (car tail)) > 45 (newtail (cdr tail))) > 46 (hash-table-set! arg-hash arg val) > 47 (if (null? newtail) remargs > 48 (loop (car newtail)(cdr newtail) remargs))))) > 49 ((member arg switches) ;; args with no params (i.e. switches) > 50 (hash-table-set! arg-hash arg #t) > 51 (if (null? tail) remargs > 52 (loop (car tail)(cdr tail) remargs))) > 53 (else > 54 (if (null? tail)(append remargs (list arg)) ;; return the non-used a > 55 (loop (car tail)(cdr tail)(append remargs (list arg)))))))) > 56 )) > 57 > 58 (define (args:print-args remargs arg-hash) > 59 (print "ARGS: " remargs) > 60 (for-each (lambda (arg) > 61 (print " " arg " " (hash-table-ref/default arg-hash arg #f))) > 62 (hash-table-keys arg-hash)))
Added megatest.scm version [1d8e12b57ca2c358]
> 1 ;; Copyright 2006-2011, Matthew Welland. > 2 ;; > 3 ;; This program is made available under the GNU GPL version 2.0 or > 4 ;; greater. See the accompanying file COPYING for details. > 5 ;; > 6 ;; This program is distributed WITHOUT ANY WARRANTY; without even the > 7 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR > 8 ;; PURPOSE. > 9 > 10 (include "common.scm") > 11 (define megatest-version 1.0) > 12 > 13 (define help (conc " > 14 Megatest, documentation at http://www.kiatoa.com/fossils/opensrc > 15 version " megatest-version " > 16 license GPL, Copyright Matt Welland 2006-2011 > 17 > 18 Usage: megatest [options] > 19 -h : this help > 20 > 21 Process and test running > 22 -runall : run all tests that are not state COMPLETED and statu > 23 -runtests tst1,tst2 ... : run tests > 24 > 25 Run status updates (these require that you are in a test directory > 26 and you have sourced the \"megatest.csh\" or > 27 \"megatest.sh\" file.) > 28 -step stepname > 29 -test-status : set the state and status of a test (use :state and : > 30 -setlog logfname : set the path/filename to the final log relative to t > 31 directory. may be used with -test-status > 32 -m comment : insert a comment for this test > 33 > 34 Run data: > 35 > 36 :runname : required, name for this particular test run > 37 :state : required if updating step state; e.g. start, end, co > 38 :status : required if updating step status; e.g. pass, fail, n > 39 > 40 Queries > 41 -list-runs patt : list runs matching pattern \"patt\", % is the wildca > 42 -showkeys : show the keys used in this megatest setup > 43 > 44 Misc (note: there is a bug in argument processing, put these at the beginning > 45 of the command line or it may fail) > 46 -force : override some checks > 47 -xterm : start an xterm instead of launching the test > 48 > 49 Helpers > 50 > 51 -runstep stepname ... : take leftover params as comand and execute as stepna > 52 log will be in stepname.log > 53 -logpro file : with -exec apply logpro file to stepname.log, create > 54 stepname.html and sets log to same > 55 > 56 Called as " (string-intersperse (argv) " "))) > 57 > 58 ;; -gui : start a gui interface > 59 ;; -config fname : override the runconfig file with fname > 60 > 61 ;; process args > 62 (define remargs (args:get-args > 63 (argv) > 64 (list "-runtests" ;; run a specific test > 65 "-config" ;; override the config file name > 66 "-execute" ;; run the command encoded in the base64 pa > 67 "-step" > 68 ":runname" > 69 ":item" > 70 ":runname" > 71 ":state" > 72 ":status" > 73 "-list-runs" > 74 "-setlog" > 75 "-runstep" > 76 "-logpro" > 77 ) > 78 (list "-h" > 79 "-force" > 80 "-xterm" > 81 "-showkeys" > 82 "-test-status" > 83 "-gui" > 84 "-runall" ;; run all tests > 85 > 86 ) > 87 args:arg-hash > 88 0)) > 89 > 90 (if (args:get-arg "-h") > 91 (begin > 92 (print help) > 93 (exit))) > 94 > 95 (include "keys.scm") > 96 (include "items.scm") > 97 (include "db.scm") > 98 (include "configf.scm") > 99 (include "process.scm") > 100 (include "launch.scm") > 101 (include "runs.scm") > 102 ;; (include "gui.scm") > 103 > 104 (define *didsomething* #f) > 105 > 106 ;;====================================================================== > 107 ;; Query runs > 108 ;;====================================================================== > 109 > 110 (if (args:get-arg "-list-runs") > 111 (let* ((db (begin > 112 (setup-for-run) > 113 (open-db))) > 114 (runpatt (args:get-arg "-list-runs")) > 115 (runsdat (db-get-runs db runpatt)) > 116 (runs (db:get-rows runsdat)) > 117 (header (db:get-header runsdat)) > 118 (keys (db-get-keys db)) > 119 (keynames (map key:get-fieldname keys))) > 120 ;; Each run > 121 (for-each > 122 (lambda (run) > 123 (print "Run: " > 124 (string-intersperse (map (lambda (x) > 125 (db-get-value-by-header run header x) > 126 keynames) "/") > 127 "/" > 128 (db-get-value-by-header run header "runname")) > 129 (let ((run-id (db-get-value-by-header run header "id"))) > 130 (let ((tests (db-get-tests-for-run db run-id))) > 131 ;; Each test > 132 (for-each > 133 (lambda (test) > 134 (format #t > 135 " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Ti > 136 (conc (db:test-get-testname test) > 137 (if (equal? (db:test-get-item-path test) "") > 138 "" > 139 (conc "(" (db:test-get-item-path test) ")"))) > 140 (db:test-get-state test) > 141 (db:test-get-status test) > 142 (db:test-get-run_duration test) > 143 (db:test-get-event_time test) > 144 (db:test-get-host test)) > 145 (if (not (or (equal? (db:test-get-status test) "PASS") > 146 (equal? (db:test-get-state test) "NOT_STARTED"))) > 147 (begin > 148 (print " cpuload: " (db:test-get-cpuload test) > 149 "\n diskfree: " (db:test-get-diskfree test) > 150 "\n uname: " (db:test-get-uname test) > 151 "\n rundir: " (db:test-get-rundir test) > 152 ) > 153 ;; Each test > 154 (let ((steps (db-get-test-steps-for-run db (db:test-get-id > 155 (for-each > 156 (lambda (step) > 157 (format #t > 158 " Step: ~20a State: ~10a Status: ~10a Time > 159 (db:step-get-stepname step) > 160 (db:step-get-state step) > 161 (db:step-get-status step) > 162 (db:step-get-event_time step))) > 163 ;; (print " Step: " (db:step-get-stepname step) > 164 ;; " " (db:step-get-state step) > 165 ;; " " (db:step-get-status step) > 166 ;; " " (db:step-get-event_time step))) > 167 steps))))) > 168 tests)))) > 169 runs) > 170 (set! *didsomething* #t) > 171 )) > 172 > 173 ;;====================================================================== > 174 ;; full run > 175 ;;====================================================================== > 176 > 177 ;; get lock in db for full run for this directory > 178 ;; for all tests with deps > 179 ;; walk tree of tests to find head tasks > 180 ;; add head tasks to task queue > 181 ;; add dependant tasks to task queue > 182 ;; add remaining tasks to task queue > 183 ;; for each task in task queue > 184 ;; if have adequate resources > 185 ;; launch task > 186 ;; else > 187 ;; put task in deferred queue > 188 ;; if still ok to run tasks > 189 ;; process deferred tasks per above steps > 190 > 191 ;; run all tests are are Not COMPLETED and PASS or CHECK > 192 (if (args:get-arg "-runall") > 193 (if (not (args:get-arg ":runname")) > 194 (begin > 195 (print "ERROR: Missing required parameter for -runtests, you must spec > 196 (exit 2)) > 197 (let* ((db (if (setup-for-run) > 198 (open-db) > 199 (begin > 200 (print "Failed to setup, exiting") > 201 (exit 1))))) > 202 (if (not (car *configinfo*)) > 203 (begin > 204 (print "ERROR: Attempted to run a test but run area config file > 205 (exit 1)) > 206 ;; put test parameters into convenient variables > 207 (let* ((test-names (get-all-legal-tests))) ;; "PROD" is ignored fo > 208 (print "INFO: Attempting to start the following tests...") > 209 (print " " (string-intersperse test-names ",")) > 210 (run-tests db test-names))) > 211 (run-waiting-tests db) > 212 (sqlite3:finalize! db) > 213 (set! *didsomething* #t)))) > 214 > 215 ;;====================================================================== > 216 ;; run one test > 217 ;;====================================================================== > 218 > 219 ;; 1. find the config file > 220 ;; 2. change to the test directory > 221 ;; 3. update the db with "test started" status, set running host > 222 ;; 4. process launch the test > 223 ;; - monitor the process, update stats in the db every 2^n minutes > 224 ;; 5. as the test proceeds internally it calls megatest as each step is > 225 ;; started and completed > 226 ;; - step started, timestamp > 227 ;; - step completed, exit status, timestamp > 228 ;; 6. test phone home > 229 ;; - if test run time > allowed run time then kill job > 230 ;; - if cannot access db > allowed disconnect time then kill job > 231 > 232 (define (runtests) > 233 (if (not (args:get-arg ":runname")) > 234 (begin > 235 (print "ERROR: Missing required parameter for -runtests, you must specif > 236 (exit 2)) > 237 (let ((db #f)) > 238 (if (not (setup-for-run)) > 239 (begin > 240 (print "Failed to setup, exiting") > 241 (exit 1))) > 242 (set! db (open-db)) > 243 (if (not (car *configinfo*)) > 244 (begin > 245 (print "ERROR: Attempted to run a test but run area config file no > 246 (exit 1)) > 247 ;; put test parameters into convenient variables > 248 (let* ((test-names (string-split (args:get-arg "-runtests") ","))) > 249 (run-tests db test-names))) > 250 ;; run-waiting-tests db) > 251 (sqlite3:finalize! db) > 252 (run-waiting-tests #f) > 253 (set! *didsomething* #t)))) > 254 > 255 (if (args:get-arg "-runtests") > 256 (runtests)) > 257 > 258 ;;====================================================================== > 259 ;; execute the test > 260 ;; - gets called on remote host > 261 ;; - receives info from the -execute param > 262 ;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file > 263 ;; - gathers host info and > 264 ;;====================================================================== > 265 > 266 (if (args:get-arg "-execute") > 267 (let* ((cmdinfo (read (open-input-string (base64:base64-decode (args:get-a > 268 (setenv "MT_CMDINFO" (args:get-arg "-execute")) > 269 (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/t > 270 (let* ((testpath (assoc/default 'testpath cmdinfo)) > 271 (work-area (assoc/default 'work-area cmdinfo)) > 272 (test-name (assoc/default 'test-name cmdinfo)) > 273 (runscript (assoc/default 'runscript cmdinfo)) > 274 (db-host (assoc/default 'db-host cmdinfo)) > 275 (run-id (assoc/default 'run-id cmdinfo)) > 276 (itemdat (assoc/default 'itemdat cmdinfo)) > 277 (fullrunscript (conc testpath "/" runscript)) > 278 (db #f)) > 279 (print "Exectuing " test-name " on " (get-host-name)) > 280 (change-directory testpath) > 281 (if (not (setup-for-run)) > 282 (begin > 283 (print "Failed to setup, exiting") > 284 (exit 1))) > 285 ;; now can find our db > 286 (set! db (open-db)) > 287 (change-directory work-area) > 288 (let ((runconfigf (conc *toppath* "/runconfigs.config"))) > 289 (if (file-exists? runconfigf) > 290 (setup-env-defaults db runconfigf run-id) > 291 (print "WARNING: You do not have a run config file: " runconfi > 292 (set-megatest-env-vars db run-id) > 293 (set-item-env-vars itemdat) > 294 (save-environment-as-files "megatest") > 295 (test-set-meta-info db run-id test-name itemdat) > 296 (test-set-status! db run-id test-name "REMOTEHOSTSTART" "n/a" itemda > 297 (if (args:get-arg "-xterm") > 298 (set! fullrunscript "xterm") > 299 (if (not (file-execute-access? fullrunscript)) > 300 (system (conc "chmod ug+x " fullrunscript)))) > 301 ;; We are about to actually kick off the test > 302 ;; so this is a good place to remove the records for > 303 ;; any previous runs > 304 ;; (db:test-remove-steps db run-id testname itemdat) > 305 > 306 ;; from here on out we will open and close the db > 307 ;; on every access to reduce the probablitiy of > 308 ;; contention or stuck access on nfs. > 309 (sqlite3:finalize! db) > 310 > 311 (let* ((m (make-mutex)) > 312 (kill-job? #f) > 313 (exit-info (make-vector 3)) > 314 (runit (lambda () > 315 (let-values > 316 (((pid exit-status exit-code) > 317 (run-n-wait fullrunscript))) > 318 (mutex-lock! m) > 319 (vector-set! exit-info 0 pid) > 320 (vector-set! exit-info 1 exit-status) > 321 (vector-set! exit-info 2 exit-code) > 322 (mutex-unlock! m)))) > 323 (monitorjob (lambda () > 324 (let* ((start-seconds (current-seconds)) > 325 (calc-minutes (lambda () > 326 (inexact->exact > 327 (round > 328 (- > 329 (current-seconds) > 330 start-seconds))))) > 331 (let loop ((minutes (calc-minutes))) > 332 (let ((db (open-db))) > 333 (set! kill-job? (test-get-kill-request > 334 (test-update-meta-info db run-id test-n > 335 (if kill-job? (process-signal (vector-r > 336 (sqlite3:finalize! db) > 337 (thread-sleep! (+ 8 (random 4))) ;; add > 338 (loop (calc-minutes))))))) > 339 (th1 (make-thread monitorjob)) > 340 (th2 (make-thread runit))) > 341 (thread-start! th1) > 342 (thread-start! th2) > 343 (thread-join! th2) > 344 (mutex-lock! m) > 345 (set! db (open-db)) > 346 (let* ((testinfo (runs:get-test-info db run-id test-name (item-lis > 347 (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) > 348 (begin > 349 (print "Test NOT logged as COMPLETED, (state=" (db:test-ge > 350 (test-set-status! db run-id test-name > 351 (if kill-job? "KILLED" "COMPLETED") > 352 (if (vector-ref exit-info 1) ;; look at > 353 (if (eq? (vector-ref exit-info 2) 0) > 354 "PASS" > 355 "FAIL") > 356 "FAIL") itemdat (args:get-arg "-m")) > 357 (mutex-unlock! m) > 358 ;; (exec-results (cmd-run->list fullrunscript)) ;; (list ">" (con > 359 ;; (success exec-results)) ;; (eq? (cadr exec-results) 0))) > 360 (print "Output from running " fullrunscript ", pid " (vector-ref e > 361 work-area ":\n====\n exit code " (vector-ref exit-info 2) " > 362 (sqlite3:finalize! db) > 363 (if (not (vector-ref exit-info 1)) > 364 (exit 4))))) > 365 (set! *didsomething* #t))) > 366 > 367 (if (args:get-arg "-step") > 368 (if (not (getenv "MT_CMDINFO")) > 369 (begin > 370 (print "ERROR: MT_CMDINFO env var not set, -step must be called *insid > 371 (exit 5)) > 372 (let* ((step (args:get-arg "-step")) > 373 (cmdinfo (read (open-input-string (base64:base64-decode (getenv > 374 (testpath (assoc/default 'testpath cmdinfo)) > 375 (test-name (assoc/default 'test-name cmdinfo)) > 376 (runscript (assoc/default 'runscript cmdinfo)) > 377 (db-host (assoc/default 'db-host cmdinfo)) > 378 (run-id (assoc/default 'run-id cmdinfo)) > 379 (itemdat (assoc/default 'itemdat cmdinfo)) > 380 (db #f) > 381 (state (args:get-arg ":state")) > 382 (status (args:get-arg ":status"))) > 383 (change-directory testpath) > 384 (if (not (setup-for-run)) > 385 (begin > 386 (print "Failed to setup, exiting") > 387 (exit 1))) > 388 (set! db (open-db)) > 389 (if (and state status) > 390 (teststep-set-status! db run-id test-name step state status itemda > 391 (begin > 392 (print "ERROR: You must specify :state and :status with every ca > 393 (exit 6))) > 394 (sqlite3:finalize! db) > 395 (set! *didsomething* #t)))) > 396 > 397 (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets pig > 398 (args:get-arg "-test-status") > 399 (args:get-arg "-runstep")) > 400 (if (not (getenv "MT_CMDINFO")) > 401 (begin > 402 (print "ERROR: MT_CMDINFO env var not set, commands -test-status, -run > 403 (exit 5)) > 404 (let* ((cmdinfo (read (open-input-string (base64:base64-decode (getenv > 405 (testpath (assoc/default 'testpath cmdinfo)) > 406 (test-name (assoc/default 'test-name cmdinfo)) > 407 (runscript (assoc/default 'runscript cmdinfo)) > 408 (db-host (assoc/default 'db-host cmdinfo)) > 409 (run-id (assoc/default 'run-id cmdinfo)) > 410 (itemdat (assoc/default 'itemdat cmdinfo)) > 411 (db #f) > 412 (state (args:get-arg ":state")) > 413 (status (args:get-arg ":status"))) > 414 (change-directory testpath) > 415 (if (not (setup-for-run)) > 416 (begin > 417 (print "Failed to setup, exiting") > 418 (exit 1))) > 419 (set! db (open-db)) > 420 (if (args:get-arg "-setlog") > 421 (test-set-log! db run-id test-name itemdat (args:get-arg "-setlog" > 422 (if (args:get-arg "-test-status") > 423 (test-set-status! db run-id test-name state status itemdat (args:g > 424 (if (and state status) > 425 (if (not (args:get-arg "-setlog")) > 426 (begin > 427 (print "ERROR: You must specify :state and :status with > 428 (sqlite3:finalize! db) > 429 (exit 6))))) > 430 (if (args:get-arg "-run-step") > 431 (if (null? remargs) > 432 (begin > 433 (print "ERROR: nothing specified to run!") > 434 (sqlite3:finalize! db) > 435 (exit 6)) > 436 (let* ((logprofile (args:get-arg "-logpro")) > 437 (cmd (if (null? remargs) #f (car remargs))) > 438 (params (if cmd (cdr remargs) #f)) > 439 (exitstat #f)) > 440 ;; mark the start of the test > 441 (test-set-status! db run-id test-name "start" "n/a" itemdat > 442 ;; close the db > 443 (sqlite3:finalize! db) > 444 ;; run the test step > 445 (set! exitstat (process-run cmd params)) > 446 ;; run logpro if applicable > 447 (if logpro > 448 (set! exitstat (process-run "logpro" logpro (conc test-n > 449 (test-set-status! db run-id test-name "end" FINISH MEEEEE!!! > 450 ;; open the db > 451 ;; mark the end of the test > 452 )) > 453 (sqlite3:finalize! db) > 454 (set! *didsomething* #t)))) > 455 > 456 (if (args:get-arg "-showkeys") > 457 (let ((db #f) > 458 (keys #f)) > 459 (if (not (setup-for-run)) > 460 (begin > 461 (print "Failed to setup, exiting") > 462 (exit 1))) > 463 (set! db (open-db)) > 464 (set! keys (db-get-keys db)) > 465 (print "Keys: " (string-intersperse (map key:get-fieldname keys) ", ")) > 466 (sqlite3:finalize! db) > 467 (set! *didsomething* #t))) > 468 > 469 (if (args:get-arg "-gui") > 470 (begin > 471 (print "Look at the dashboard for now") > 472 ;; (megatest-gui) > 473 (set! *didsomething* #t))) > 474 > 475 (if (not *didsomething*) > 476 (print help))
Added process.scm version [d31db054ad759d56]
> 1 ;;====================================================================== > 2 ;; Copyright 2006-2011, Matthew Welland. > 3 ;; > 4 ;; This program is made available under the GNU GPL version 2.0 or > 5 ;; greater. See the accompanying file COPYING for details. > 6 ;; > 7 ;; This program is distributed WITHOUT ANY WARRANTY; without even the > 8 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR > 9 ;; PURPOSE. > 10 ;;====================================================================== > 11 > 12 ;;====================================================================== > 13 ;; Process convience utils > 14 ;;====================================================================== > 15 > 16 (define (cmd-run-proc-each-line cmd proc . params) > 17 (let* ((fh (process cmd params))) > 18 (let loop ((curr (read-line fh)) > 19 (result '())) > 20 (if (not (eof-object? curr)) > 21 (loop (read-line fh) > 22 (append result (list (proc curr)))) > 23 result)))) > 24 > 25 (define (cmd-run-proc-each-line-alt cmd proc) > 26 (let* ((fh (open-input-pipe cmd)) > 27 (res (port-proc->list fh proc)) > 28 (status (close-input-pipe fh))) > 29 (if (eq? status 0) res #f))) > 30 > 31 (define (cmd-run->list cmd) > 32 (let* ((fh (open-input-pipe cmd)) > 33 (res (port->list fh)) > 34 (status (close-input-pipe fh))) > 35 (list res status))) > 36 > 37 (define (port->list fh) > 38 (if (eof-object? fh) #f > 39 (let loop ((curr (read-line fh)) > 40 (result '())) > 41 (if (not (eof-object? curr)) > 42 (loop (read-line fh) > 43 (append result (list curr))) > 44 result)))) > 45 > 46 (define (port-proc->list fh proc) > 47 (if (eof-object? fh) #f > 48 (let loop ((curr (proc (read-line fh))) > 49 (result '())) > 50 (if (not (eof-object? curr)) > 51 (loop (let ((l (read-line fh))) > 52 (if (eof-object? l) l (proc l))) > 53 (append result (list curr))) > 54 result)))) > 55 > 56 ;; here is an example line where the shell is sh or bash > 57 ;; "find / -print 2&>1 > findall.log" > 58 (define (run-n-wait cmdline) > 59 (let ((pid (process-run cmdline))) > 60 (let loop ((i 0)) > 61 (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) > 62 (if (eq? pid-val 0) > 63 (begin > 64 (thread-sleep! 2) > 65 (loop (+ i 1))) > 66 (values pid-val exit-status exit-code)))))) > 67
Added runs.scm version [62d4c34f375dd67e]
> 1 > 2 ;; Copyright 2006-2011, Matthew Welland. > 3 ;; > 4 ;; This program is made available under the GNU GPL version 2.0 or > 5 ;; greater. See the accompanying file COPYING for details. > 6 ;; > 7 ;; This program is distributed WITHOUT ANY WARRANTY; without even the > 8 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR > 9 ;; PURPOSE. > 10 > 11 ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') > 12 > 13 ;; register a test run with the db > 14 (define (register-run db keys) ;; test-name) > 15 (let* ((keystr (keys->keystr keys)) > 16 (comma (if (> (length keys) 0) "," "")) > 17 (andstr (if (> (length keys) 0) " AND " "")) > 18 (valslots (keys->valslots keys)) ;; ?,?,? ... > 19 (keyvallst (keys->vallist keys)) > 20 (runname (get-with-default ":runname" #f)) > 21 (state (get-with-default ":state" "no")) > 22 (status (get-with-default ":status" "n/a")) > 23 (allvals (append (list runname state status user) keyvallst)) > 24 (qryvals (append (list runname) keyvallst)) > 25 (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname > 26 ;; (print "keys: " keys " allvals: " allvals " keyvallst: " keyvallst) > 27 (print "NOTE: using key " (string-intersperse keyvallst "/") " for this run" > 28 (if (and runname (null? (filter (lambda (x)(not x)) keyvallst))) ;; there mu > 29 (let ((res #f)) > 30 (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,s > 31 allvals) > 32 (apply sqlite3:for-each-row > 33 (lambda (id) > 34 (set! res id)) > 35 db > 36 (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=? > 37 ;; (print "qry: " qry) > 38 qry) > 39 qryvals) > 40 (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" sta > 41 res) > 42 (begin > 43 (print "ERROR: Called without all necessary keys") > 44 #f)))) > 45 > 46 (define (register-test db run-id test-name item-path) > 47 (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,i > 48 > 49 (define (test-set-status! db run-id test-name state status itemdat-or-path . com > 50 (let ((item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->pat > 51 (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime(' > 52 state status run-id test-name item-path) > 53 (if (and (not (null? comment)) > 54 (car comment)) > 55 (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testn > 56 (car comment) run-id test-name item-path)))) > 57 > 58 (define (test-set-log! db run-id test-name itemdat logf) > 59 (let ((item-path (item-list->path itemdat))) > 60 (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testna > 61 logf run-id test-name item-path))) > 62 > 63 ;; TODO: Converge this with db:get-test-info > 64 (define (runs:get-test-info db run-id test-name item-path) > 65 (let ((res #f)) ;; (vector #f #f #f #f #f #f))) > 66 (sqlite3:for-each-row > 67 (lambda (id run-id test-name state status) > 68 (set! res (vector id run-id test-name state status item-path))) > 69 db "SELECT id,run_id,testname,state,status FROM tests WHERE run_id=? AND te > 70 run-id test-name item-path) > 71 res)) > 72 > 73 (define-inline (test:get-id vec) (vector-ref vec 0)) > 74 (define-inline (test:get-run_id vec) (vector-ref vec 1)) > 75 (define-inline (test:get-test-name vec)(vector-ref vec 2)) > 76 (define-inline (test:get-state vec) (vector-ref vec 3)) > 77 (define-inline (test:get-status vec) (vector-ref vec 4)) > 78 (define-inline (test:get-item-path vec)(vector-ref vec 5)) > 79 > 80 (define (runs:test-get-full-path test) > 81 (let* ((testname (db:test-get-testname test)) > 82 (itempath (db:test-get-item-path test))) > 83 (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) > 84 > 85 (define-inline (test:test-get-fullname test) > 86 (conc (db:test-get-testname test) > 87 (if (equal? (db:test-get-item-path test) "") > 88 "" > 89 (conc "(" (db:test-get-item-path test) ")")))) > 90 > 91 (define (check-valid-items class item) > 92 (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class))) > 93 (if s (string-split s) #f)))) > 94 (if valid-values > 95 (if (member item valid-values) > 96 item #f) > 97 item))) > 98 > 99 (define (teststep-set-status! db run-id test-name teststep-name state-in status- > 100 ;; (print "run-id: " run-id " test-name: " test-name) > 101 (let* ((state (check-valid-items "state" state-in)) > 102 (status (check-valid-items "status" status-in)) > 103 (item-path (item-list->path itemdat)) > 104 (testdat (runs:get-test-info db run-id test-name item-path))) > 105 ;; (print "testdat: " testdat) > 106 (if (and testdat ;; if the section exists then force specification BUG, I do > 107 (or (not state)(not status))) > 108 (print "WARNING: Invalid " (if status "status" "state") > 109 " value \"" (if status status-in state-in) "\", update your valid > 110 (if testdat > 111 (let ((test-id (test:get-id testdat))) > 112 (sqlite3:execute db > 113 "INSERT OR REPLACE into test_steps (test_id,stepname,sta > 114 test-id teststep-name state status)) > 115 (print "ERROR: Can't update " test-name " for run " run-id " -> no such > 116 > 117 (define (test-get-kill-request db run-id test-name itemdat) > 118 (let* ((item-path (item-list->path itemdat)) > 119 (testdat (runs:get-test-info db run-id test-name item-path))) > 120 (equal? (test:get-state testdat) "KILLREQ"))) > 121 > 122 (define (test-set-meta-info db run-id testname itemdat) > 123 (let ((item-path (item-list->path itemdat)) > 124 (cpuload (get-cpu-load)) > 125 (hostname (get-host-name)) > 126 (diskfree (get-df (current-directory))) > 127 (uname (get-uname "-srvpio")) > 128 (runpath (current-directory))) > 129 (sqlite3:execute db "UPDATE tests SET host=?,cpuload=?,diskfree=?,uname=?,ru > 130 hostname > 131 cpuload > 132 diskfree > 133 uname > 134 runpath > 135 run-id > 136 testname > 137 item-path))) > 138 > 139 (define (test-update-meta-info db run-id testname itemdat minutes) > 140 (let ((item-path (item-list->path itemdat)) > 141 (cpuload (get-cpu-load)) > 142 (diskfree (get-df (current-directory)))) > 143 (if (not cpuload) (begin (print "WARNING: CPULOAD not found.") (set! cpulo > 144 (if (not diskfree) (begin (print "WARNING: DISKFREE not found.") (set! diskf > 145 (if (not item-path)(begin (print "WARNING: ITEMPATH not set.") (set! item- > 146 ;; (let ((testinfo (db:get-test-info db run-id testname item-path))) > 147 ;; (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED")) > 148 ;; (not (equal? (db:test-get-status testinfo) "KILLREQ")) > 149 (sqlite3:execute > 150 db > 151 "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE > 152 cpuload > 153 diskfree > 154 minutes > 155 run-id > 156 testname > 157 item-path))) > 158 > 159 (define (set-megatest-env-vars db run-id) > 160 (let ((keys (db-get-keys db))) > 161 (for-each (lambda (key) > 162 (sqlite3:for-each-row > 163 (lambda (val) > 164 (print "setenv " (key:get-fieldname key) " " val) > 165 (setenv (key:get-fieldname key) val)) > 166 db > 167 (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?; > 168 run-id)) > 169 keys))) > 170 > 171 (define (set-item-env-vars itemdat) > 172 (for-each (lambda (item) > 173 (print "setenv " (car item) " " (cadr item)) > 174 (setenv (car item) (cadr item))) > 175 itemdat)) > 176 > 177 (define (get-all-legal-tests) > 178 (let* ((tests (glob (conc *toppath* "/tests/*"))) > 179 (res '())) > 180 ;; (print "INFO: Looking at tests " (string-intersperse tests ",")) > 181 (for-each (lambda (testpath) > 182 (if (file-exists? (conc testpath "/testconfig")) > 183 (set! res (cons (last (string-split testpath "/")) res)))) > 184 tests) > 185 res)) > 186 > 187 (define (run-tests db test-names) > 188 (for-each > 189 (lambda (test-name) > 190 (run-one-test db test-name)) > 191 test-names)) > 192 > 193 (define (run-one-test db test-name) > 194 (print "Launching test " test-name) > 195 (let* ((test-path (conc *toppath* "/tests/" test-name)) > 196 (test-configf (conc test-path "/testconfig")) > 197 (testexists (and (file-exists? test-configf)(file-read-access? test-c > 198 (test-conf (if testexists (read-config test-configf) (make-hash-tabl > 199 (waiton (let ((w (config-lookup test-conf "requirements" "waiton" > 200 (if (string? w)(string-split w)'())))) > 201 (if (not testexists) > 202 (begin > 203 (print "ERROR: Can't find config file " test-configf) > 204 (exit 2)) > 205 ;; put top vars into convenient variables and open the db > 206 (let* (;; db is always at *toppath*/db/megatest.db > 207 (keys (db-get-keys db)) > 208 (keyvallst (keys->vallist keys #t)) > 209 (items (hash-table-ref/default test-conf "items" #f)) > 210 (allitems (item-assoc->item-list items)) > 211 (run-id (register-run db keys)) ;; test-name))) > 212 (runconfigf (conc *toppath* "/runconfigs.config"))) > 213 ;; (print "items: ")(pp allitems) > 214 (let loop ((itemdat (car allitems)) > 215 (tal (cdr allitems))) > 216 ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") > 217 (let* ((item-path (item-list->path itemdat)) ;; (string-interspe > 218 (new-test-path (string-intersperse (cons test-path (map cadr > 219 (new-test-name (if (equal? item-path "") test-name (conc test > 220 (test-status #f)) > 221 (let loop2 ((ts #f) > 222 (ct 0)) > 223 (if (and (not ts) > 224 (< ct 10)) > 225 (begin > 226 (register-test db run-id test-name item-path) > 227 (loop2 (runs:get-test-info db run-id test-name item-path) > 228 (+ ct 1))) > 229 (if ts > 230 (set! test-status ts) > 231 (begin > 232 (print "WARNING: Couldn't register test " test-name " > 233 (if (not (null? tal)) > 234 (loop (car tal)(cdr tal))))))) > 235 (change-directory test-path) > 236 ;; this block is here only to inform the user early on > 237 (if (file-exists? runconfigf) > 238 (setup-env-defaults db runconfigf run-id *already-seen-runconf > 239 (print "WARNING: You do not have a run config file: " runconfi > 240 ;; (print "run-id: " run-id " test-name: " test-name " item-path: > 241 (case (if (args:get-arg "-force") > 242 'NOT_STARTED > 243 (if test-status > 244 (string->symbol (test:get-state test-status)) > 245 'failed-to-insert)) > 246 ((failed-to-insert) > 247 (print "ERROR: Failed to insert the record into the db")) > 248 ((NOT_STARTED COMPLETED) ;; (cadr status is the row id for the r > 249 (if (and (equal? (test:get-state test-status) "COMPLETED") > 250 (equal? (test:get-status test-status) "PASS") > 251 (not (args:get-arg "-force"))) > 252 (print "NOTE: Not starting test " new-test-name " as it is > 253 (let* ((get-prereqs-cmd (lambda () > 254 (db-get-prereqs-not-met db run-id > 255 (launch-cmd (lambda () > 256 (launch-test db run-id test-conf > 257 (testrundat (list get-prereqs-cmd launch-cmd))) > 258 (if (or (args:get-arg "-force") > 259 (null? ((car testrundat)))) ;; are there any test > 260 ((cadr testrundat)) ;; this is the line that launches > 261 (hash-table-set! *waiting-queue* new-test-name testru > 262 ((LAUNCHED REMOTEHOSTSTART KILLED) > 263 (print "NOTE: " new-test-name " is already running or was expli > 264 ((RUNNING) (print "NOTE: " test-name " is already running")) > 265 (else (print "ERROR: Failed to launch test " new-test-name > 266 (if (not (null? tal)) > 267 (loop (car tal)(cdr tal)))))))) > 268 > 269 (define (run-waiting-tests db) > 270 (let ((numtries 0) > 271 (last-try-time (current-seconds)) > 272 (times (list 1))) ;; minutes to wait before trying again to > 273 ;; BUG this hack of brute force retrying works quite well for many cases but > 274 ;; what is needed is to check the db for tests that have failed less tha > 275 ;; N times or never been started and kick them off again > 276 (let loop ((waiting-test-names (hash-table-keys *waiting-queue*))) > 277 (cond > 278 ((null? waiting-test-names) > 279 (print "All tests launched")) > 280 ((> numtries 4) > 281 (print "NOTE: Tried launching four times, perhaps run megatest again in > 282 (else > 283 (set! numtries (+ numtries 1)) > 284 (for-each (lambda (testname) > 285 (let* ((testdat (hash-table-ref *waiting-queue* testname)) > 286 (prereqs ((car testdat))) > 287 (ldb (if db db (open-db)))) > 288 ;; (print "prereqs remaining: " prereqs) > 289 (if (null? prereqs) > 290 (begin > 291 (print "Prerequisites met, launching " testname) > 292 ((cadr testdat)) > 293 (hash-table-delete! *waiting-queue* testname))) > 294 (if (not db) > 295 (sqlite3:finalize! ldb)))) > 296 waiting-test-names) > 297 (sleep 10) ;; no point in rushing things at this stage? > 298 (loop (hash-table-keys *waiting-queue*))))))) > 299
Added tests/Makefile version [9d37a344c8c7e1b6]
Added tests/megatest.config version [40d2ea3ec3570ea4]
> 1 [fields] > 2 sysname TEXT > 3 fsname TEXT > 4 datapath TEXT > 5 > 6 [setup] > 7 executable megatest > 8 > 9 [jobtools] > 10 # ## launcher launches jobs, the job is managed on the target host > 11 ## by megatest, comment out launcher to run local > 12 # workhosts localhost hermes > 13 launcher nbfake > 14 > 15 [validvalues] > 16 state start end completed > 17 status pass fail n/a > 18 > 19 [env-override] > 20 SPECIAL_ENV_VARS overide them here - all tests see these > 21 > 22 ## disks are: > 23 ## name host:/path/to/area > 24 ## -or- > 25 ## name /path/to/area > 26 [disks] > 27 1 /tmp
Added tests/runconfigs.config version [ddf71be59a6a7bd6]
Added tests/supportfiles/ruby/librunscript.rb version [a529a5a104460a32]
> 1 # This is the library of stuff for megatest > 2 > 3 def run_and_record(stepname, cmd, checks) > 4 system "megatest -step #{stepname} :state start :status n/a" > 5 system cmd > 6 exitcode=$? > 7 if exitcode==0 > 8 exitcode='pass' > 9 else > 10 exitcode='fail' > 11 end > 12 system "megatest -step #{stepname} :state end :status #{exitcode}" > 13 end > 14 > 15 def record_step(stepname,state,status) > 16 system "megatest -step #{stepname} :state #{state} :status #{status}" > 17 end > 18 > 19 def test_status(state,status) > 20 system "megatest -test-status :state #{state} :status #{status}" > 21 end > 22 > 23 > 24 # WARNING: This example is deprecated. Don't use the -test-status command > 25 # unless you know for sure what you are doing. > 26 def file_size_checker(stepname,filename,minsize,maxsize) > 27 fsize=File.size(filename) > 28 if fsize > maxsize or fsize < minsize > 29 system "megatest -test-status :state COMPLETED :status fail" > 30 else > 31 system "megatest -test-status :state COMPLETED :status pass" > 32 end > 33 end > 34 > 35 > 36 def wait_for_step(testname,stepname) > 37 end
Added tests/test.config version [50c4aca4399d9e05]
> 1 [section1] > 2 1 ./blah > 3 > 4 [section2] > 5 > 6 # A comment > 7 > 8 [disks] > 9 1 ./ > 10 > 11 [validvalues] > 12 state start end aborted > 13 status pass fail n/a > 14 > 15 [include a file that doesn't exist] > 16 > 17 > 18 blah nada > 19 > 20 # now inlcude a file tha tdoes exist > 21 [include megatest.config]
Added tests/tests.scm version [0b7d0d8b1eb547d4]
> 1 (use test) > 2 ;; (require-library args) > 3 > 4 (include "../common.scm") > 5 (include "../keys.scm") > 6 (include "../db.scm") > 7 (include "../configf.scm") > 8 (include "../process.scm") > 9 (include "../launch.scm") > 10 (include "../items.scm") > 11 (include "../runs.scm") > 12 > 13 (define conffile #f) > 14 (test "Read a config" #t (hash-table? (read-config "test.config"))) > 15 (test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.conf > 16 > 17 (set! conffile (read-config "test.config")) > 18 (test "Get available diskspace" #t (number? (get-df "./"))) > 19 (test "Get best dir" #t (let ((bestdir (get-best-disk conffile))) > 20 (or (equal? "./" bestdir) > 21 (equal? "/tmp" bestdir)))) > 22 > 23 ;; db > 24 (define row (vector "a" "b" "c" "blah")) > 25 (define header (list "col1" "col2" "col3" "col4")) > 26 (test "Get row by header" "blah" (db-get-value-by-header row header "col4")) > 27 > 28 ;; (define *toppath* "tests") > 29 (define *db* #f) > 30 (test "setup for run" #t (begin (setup-for-run) > 31 (string? (getenv "MT_RUN_AREA_HOME")))) > 32 (test "open-db" #t (begin > 33 (set! *db* (open-db)) > 34 (if *db* #t #f))) > 35 > 36 (test "get cpu load" #t (number? (get-cpu-load))) > 37 (test "get uname" #t (string? (get-uname))) > 38 > 39 (test "get validvalues as list" (list "start" "end" "completed") > 40 (string-split (config-lookup *configdat* "validvalues" "state"))) > 41 > 42 (for-each (lambda (item) > 43 (test (conc "get valid items (" item ")") > 44 item (check-valid-items "state" item))) > 45 (list "start" "end" "completed")) > 46 > 47 (for-each (lambda (item) > 48 (test (conc "get valid items (" item ")") > 49 item (check-valid-items "status" item))) > 50 (list "pass" "fail" "n/a")) > 51 > 52 (test "write env files" "nada.csh" (begin > 53 (save-environment-as-files "nada") > 54 (and (file-exists? "nada.sh") > 55 (file-exists? "nada.csh")))) > 56 > 57 (test "get all legal tests" (list "runfirst" "sqlitespeed") (sort (get-all-legal > 58 > 59 (test "register-test, test info" "NOT_STARTED" > 60 (begin > 61 (register-test *db* 1 "nada" "") > 62 (test:get-state (runs:get-test-info *db* 1 "nada" "")))) > 63 > 64 (test "get-keys" "sysname" (key:get-fieldname (car (sort (db-get-keys *db*)(lamb > 65 > 66 (define remargs (args:get-args > 67 '("bar" "foo" ":runname" "bob" ":sysname" "ubuntu" ":fsname" "n > 68 (list ":runname" ":state" ":status") > 69 (list "-h") > 70 args:arg-hash > 71 0)) > 72 > 73 (test "register-run" #t (number? (register-run *db* (db-get-keys *db*)))) > 74 > 75 ;;(test "update-test-info" #t (test-update-meta-info *db* 1 "nada" > 76 (setenv "BLAHFOO" "1234") > 77 (unsetenv "NADAFOO") > 78 (test "env temp overrides" "xyz" (let ((prevvals (alist->env-vars '(("BLAHFOO" 4 > 79 (result (get-environment-variable "NADA > 80 (alist->env-vars prevvals) > 81 result)) > 82 > 83 (test "env restored" "1234" (get-environment-variable "BLAHFOO")) > 84 > 85
Added tests/tests/runfirst/main.sh version [509a06d02e6d0d3b]
Added tests/tests/runfirst/testconfig version [8ed50f0680400c11]
> 1 [setup] > 2 runscript main.sh > 3 > 4 [requirements] > 5 diskspace 1M > 6 memory 1G > 7 > 8 [pre-launch-env-vars] > 9 # These are set before the test is launched on the originating > 10 # host. This can be used to control remote launch tools, e.g. to > 11 # to choose the target host, select the launch tool etc. > 12 SPECIAL_ENV_VAR override with everything after the first space. > 13 > 14 [items] > 15 SEASON summer winter fall spring > 16
Added tests/tests/sqlitespeed/runscript.rb version [df18637493bcc06d]
> 1 #! /usr/bin/ruby > 2 > 3 require "#{ENV['MT_RUN_AREA_HOME']}/supportfiles/ruby/librunscript.rb" > 4 > 5 # run_record(stepname, cmd) - will record in db if exit code of script was zero > 6 run_and_record('create db',"sqlite3 testing.db << EOF\ncreate table if not exist > 7 > 8 # file_size_checker(stepname, filename, minsize, maxsize) - negative means ignor > 9 # file_size_checker('create db','testing.db',100,-1) > 10 > 11 num_records=rand(60) # 0000 > 12 record_step("add #{num_records}","start","n/a") > 13 status=false > 14 (0..num_records).each do |i| > 15 randstring="a;lskdfja;sdfj;alsdfj;aslfdj;alsfja;lsfdj;alsfja;lsjfd;lasfjl;asdf > 16 # status=system "sqlite3 testing.db \"insert into blah (name) values ('#{rands > 17 system "megatest -step testing :state wrote_junk :status #{num_records}" > 18 sleep(1) > 19 puts "i=#{i}" > 20 end > 21 if status==0 > 22 status='pass' > 23 else > 24 status='fail' > 25 end > 26 record_step("add #{num_records}","end",status) > 27 > 28 > 29 > 30
Added tests/tests/sqlitespeed/testconfig version [eb2322e05761dd60]
> 1 [setup] > 2 runscript runscript.rb > 3 > 4 [requirements] > 5 diskspace 1M > 6 memory 1G > 7 waiton runfirst > 8 > 9 [env-override] > 10 # Test specific environment overrides go here > 11 SPECIAL_ENV_VAR override with everything after the space. > 12 > 13 [items] > 14 MANYITEMS a b c d e f g h i j k l m
Added utils/nbfake version [81bcd8f6dcb3d59d]
> 1 #!/bin/bash > 2 > 3 # ssh localhost "nohup $* > nbfake.log 2> nbfake.err < /dev/null" > 4 > 5 if [[ $TARGETHOST == "" ]]; then > 6 TARGETHOST=localhost > 7 fi > 8 > 9 # Can't always trust $PWD > 10 CURRWD=`pwd` > 11 > 12 ssh -n -f $TARGETHOST "sh -c \"cd $CURRWD; nohup $* > NBFAKE-`date +%GWW%V.%u_%T
Added utils/runner version [229dc9c405ebb9e2]
> 1 #!/usr/bin/perl -w > 2 > 3 $starthr=`date +%k`; > 4 $hrsper = 1; > 5 $nexthr=$starthr + $hrsper; > 6 > 7 $ltr='a'; > 8 > 9 while (1) { > 10 $runname = `date +%GWW%V.%u`; > 11 chomp $runname; > 12 $runname = $runname . $ltr; > 13 $cmd = "megatest -runall :datapath testing :fsname local :sysname ubuntu :runn > 14 print "Running $cmd\n"; > 15 system $cmd; > 16 $currhr = `date +%k`; > 17 if ($currhr > $nexthr) { > 18 $ltr = chr(ord($ltr)+1); > 19 $nexthr=$nexthr + $hrsper; > 20 } > 21 if ($nexthr > 23) { > 22 $nexthr = 0; > 23 } > 24 sleep 10; > 25 } > 26 > 27